]>
git.ipfire.org Git - thirdparty/git.git/blob - git-cvsserver.perl
2e9b6733729d5f95b5b3ea613376794610d05df1
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 # if we are called with a pserver argument,
91 # deal with the authentication cat before entering the
93 if ( @ARGV && $ARGV [ 0 ] eq 'pserver' ) {
94 my $line = < STDIN
>; chomp $line ;
95 unless ( $line eq 'BEGIN AUTH REQUEST' ) {
96 die "E Do not understand $line - expecting BEGIN AUTH REQUEST \n " ;
98 $line = < STDIN
>; chomp $line ;
99 req_Root
( 'root' , $line ) # reuse Root
100 or die "E Invalid root $line \n " ;
101 $line = < STDIN
>; chomp $line ;
102 unless ( $line eq 'anonymous' ) {
103 print "E Only anonymous user allowed via pserver \n " ;
104 print "I HATE YOU \n " ;
106 $line = < STDIN
>; chomp $line ; # validate the password?
107 $line = < STDIN
>; chomp $line ;
108 unless ( $line eq 'END AUTH REQUEST' ) {
109 die "E Do not understand $line -- expecting END AUTH REQUEST \n " ;
111 print "I LOVE YOU \n " ;
112 # and now back to our regular programme...
115 # Keep going until the client closes the connection
120 # Check to see if we've seen this method, and call appropriate function.
121 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined ( $methods ->{ $1 }) )
123 # use the $methods hash to call the appropriate sub for this command
124 #$log->info("Method : $1");
125 &{ $methods ->{ $1 }}( $1 , $2 );
127 # log fatal because we don't understand this function. If this happens
128 # we're fairly screwed because we don't know if the client is expecting
129 # a response. If it is, the client will hang, we'll hang, and the whole
130 # thing will be custard.
131 $log -> fatal ( "Don't understand command $_ \n " );
132 die ( "Unknown command $_ " );
136 $log -> debug ( "Processing time : user=" . ( times )[ 0 ] . " system=" . ( times )[ 1 ]);
137 $log -> info ( "--------------- FINISH -----------------" );
139 # Magic catchall method.
140 # This is the method that will handle all commands we haven't yet
141 # implemented. It simply sends a warning to the log file indicating a
142 # command that hasn't been implemented has been invoked.
145 my ( $cmd , $data ) = @_ ;
146 $log -> warn ( "Unhandled command : req_ $cmd : $data " );
151 # Response expected: no. Tell the server which CVSROOT to use. Note that
152 # pathname is a local directory and not a fully qualified CVSROOT variable.
153 # pathname must already exist; if creating a new root, use the init
154 # request, not Root. pathname does not include the hostname of the server,
155 # how to access the server, etc.; by the time the CVS protocol is in use,
156 # connection, authentication, etc., are already taken care of. The Root
157 # request must be sent only once, and it must be sent before any requests
158 # other than Valid-responses, valid-requests, UseUnchanged, Set or init.
161 my ( $cmd , $data ) = @_ ;
162 $log -> debug ( "req_Root : $data " );
164 $state ->{ CVSROOT
} = $data ;
166 $ENV { GIT_DIR
} = $state ->{ CVSROOT
} . "/" ;
167 unless (- d
$ENV { GIT_DIR
} && - e
$ENV { GIT_DIR
}. 'HEAD' ) {
168 print "E $ENV {GIT_DIR} does not seem to be a valid GIT repository \n " ;
170 print "error 1 $ENV {GIT_DIR} is not a valid repository \n " ;
174 my @gitvars = `git-repo-config -l` ;
176 print "E problems executing git-repo-config on the server -- this is not a git repository or the PATH is not set correctly. \n " ;
178 print "error 1 - problem executing git-repo-config \n " ;
181 foreach my $line ( @gitvars )
183 next unless ( $line =~ /^(.*?)\.(.*?)=(.*)$/ );
187 unless ( defined ( $cfg ->{ gitcvs
}{ enabled
} ) and $cfg ->{ gitcvs
}{ enabled
} =~ /^\s*(1|true|yes)\s*$/i )
189 print "E GITCVS emulation needs to be enabled on this repo \n " ;
190 print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1 \n " ;
192 print "error 1 GITCVS emulation disabled \n " ;
196 if ( defined ( $cfg ->{ gitcvs
}{ logfile
} ) )
198 $log -> setfile ( $cfg ->{ gitcvs
}{ logfile
});
206 # Global_option option \n
207 # Response expected: no. Transmit one of the global options `-q', `-Q',
208 # `-l', `-t', `-r', or `-n'. option must be one of those strings, no
209 # variations (such as combining of options) are allowed. For graceful
210 # handling of valid-requests, it is probably better to make new global
211 # options separate requests, rather than trying to add them to this
215 my ( $cmd , $data ) = @_ ;
216 $log -> debug ( "req_Globaloption : $data " );
218 # TODO : is this data useful ???
221 # Valid-responses request-list \n
222 # Response expected: no. Tell the server what responses the client will
223 # accept. request-list is a space separated list of tokens.
224 sub req_Validresponses
226 my ( $cmd , $data ) = @_ ;
227 $log -> debug ( "req_Validresponses : $data " );
229 # TODO : re-enable this, currently it's not particularly useful
230 #$state->{validresponses} = [ split /\s+/, $data ];
234 # Response expected: yes. Ask the server to send back a Valid-requests
236 sub req_validrequests
238 my ( $cmd , $data ) = @_ ;
240 $log -> debug ( "req_validrequests" );
242 $log -> debug ( "SEND : Valid-requests " . join ( " " , keys % $methods ));
243 $log -> debug ( "SEND : ok" );
245 print "Valid-requests " . join ( " " , keys % $methods ) . " \n " ;
249 # Directory local-directory \n
250 # Additional data: repository \n. Response expected: no. Tell the server
251 # what directory to use. The repository should be a directory name from a
252 # previous server response. Note that this both gives a default for Entry
253 # and Modified and also for ci and the other commands; normal usage is to
254 # send Directory for each directory in which there will be an Entry or
255 # Modified, and then a final Directory for the original directory, then the
256 # command. The local-directory is relative to the top level at which the
257 # command is occurring (i.e. the last Directory which is sent before the
258 # command); to indicate that top level, `.' should be sent for
262 my ( $cmd , $data ) = @_ ;
264 my $repository = < STDIN
>;
268 $state ->{ localdir
} = $data ;
269 $state ->{ repository
} = $repository ;
270 $state ->{ directory
} = $repository ;
271 $state ->{ directory
} =~ s/^$state->{CVSROOT}\// /;
272 $state ->{ module
} = $1 if ( $state ->{ directory
} =~ s/^(.*?)(\/|$)/ /);
273 $state ->{ directory
} .= "/" if ( $state ->{ directory
} =~ / \S
/ );
275 $log -> debug ( "req_Directory : localdir= $data repository= $repository directory= $state ->{directory} module= $state ->{module}" );
278 # Entry entry-line \n
279 # Response expected: no. Tell the server what version of a file is on the
280 # local machine. The name in entry-line is a name relative to the directory
281 # most recently specified with Directory. If the user is operating on only
282 # some files in a directory, Entry requests for only those files need be
283 # included. If an Entry request is sent without Modified, Is-modified, or
284 # Unchanged, it means the file is lost (does not exist in the working
285 # directory). If both Entry and one of Modified, Is-modified, or Unchanged
286 # are sent for the same file, Entry must be sent first. For a given file,
287 # one can send Modified, Is-modified, or Unchanged, but not more than one
291 my ( $cmd , $data ) = @_ ;
293 $log -> debug ( "req_Entry : $data " );
295 my @data = split ( /\/ /, $data );
297 $state ->{ entries
}{ $state ->{ directory
}. $data [ 1 ]} = {
298 revision
=> $data [ 2 ],
299 conflict
=> $data [ 3 ],
301 tag_or_date
=> $data [ 5 ],
306 # Response expected: yes. Add a file or directory. This uses any previous
307 # Argument, Directory, Entry, or Modified requests, if they have been sent.
308 # The last Directory sent specifies the working directory at the time of
309 # the operation. To add a directory, send the directory to be added using
310 # Directory and Argument requests.
313 my ( $cmd , $data ) = @_ ;
319 foreach my $filename ( @
{ $state ->{ args
}} )
321 $filename = filecleanup
( $filename );
323 unless ( defined ( $state ->{ entries
}{ $filename }{ modified_filename
} ) )
325 print "E cvs add: nothing known about ` $filename ' \n " ;
328 # TODO : check we're not squashing an already existing file
329 if ( defined ( $state ->{ entries
}{ $filename }{ revision
} ) )
331 print "E cvs add: ` $filename ' has already been entered \n " ;
336 my ( $filepart , $dirpart ) = filenamesplit
( $filename );
338 print "E cvs add: scheduling file ` $filename ' for addition \n " ;
340 print "Checked-in $dirpart \n " ;
342 print "/ $filepart /0/// \n " ;
347 if ( $addcount == 1 )
349 print "E cvs add: use `cvs commit' to add this file permanently \n " ;
351 elsif ( $addcount > 1 )
353 print "E cvs add: use `cvs commit' to add these files permanently \n " ;
360 # Response expected: yes. Remove a file. This uses any previous Argument,
361 # Directory, Entry, or Modified requests, if they have been sent. The last
362 # Directory sent specifies the working directory at the time of the
363 # operation. Note that this request does not actually do anything to the
364 # repository; the only effect of a successful remove request is to supply
365 # the client with a new entries line containing `-' to indicate a removed
366 # file. In fact, the client probably could perform this operation without
367 # contacting the server, although using remove may cause the server to
368 # perform a few more checks. The client sends a subsequent ci request to
369 # actually record the removal in the repository.
372 my ( $cmd , $data ) = @_ ;
376 # Grab a handle to the SQLite db and do any necessary updates
377 my $updater = GITCVS
:: updater
-> new ( $state ->{ CVSROOT
}, $state ->{ module
}, $log );
380 #$log->debug("add state : " . Dumper($state));
384 foreach my $filename ( @
{ $state ->{ args
}} )
386 $filename = filecleanup
( $filename );
388 if ( defined ( $state ->{ entries
}{ $filename }{ unchanged
} ) or defined ( $state ->{ entries
}{ $filename }{ modified_filename
} ) )
390 print "E cvs remove: file ` $filename ' still in working directory \n " ;
394 my $meta = $updater -> getmeta ( $filename );
395 my $wrev = revparse
( $filename );
397 unless ( defined ( $wrev ) )
399 print "E cvs remove: nothing known about ` $filename ' \n " ;
403 if ( defined ( $wrev ) and $wrev < 0 )
405 print "E cvs remove: file ` $filename ' already scheduled for removal \n " ;
409 unless ( $wrev == $meta ->{ revision
} )
411 # TODO : not sure if the format of this message is quite correct.
412 print "E cvs remove: Up to date check failed for ` $filename ' \n " ;
417 my ( $filepart , $dirpart ) = filenamesplit
( $filename );
419 print "E cvs remove: scheduling ` $filename ' for removal \n " ;
421 print "Checked-in $dirpart \n " ;
423 print "/ $filepart /-1. $wrev /// \n " ;
430 print "E cvs remove: use `cvs commit' to remove this file permanently \n " ;
432 elsif ( $rmcount > 1 )
434 print "E cvs remove: use `cvs commit' to remove these files permanently \n " ;
440 # Modified filename \n
441 # Response expected: no. Additional data: mode, \n, file transmission. Send
442 # the server a copy of one locally modified file. filename is a file within
443 # the most recent directory sent with Directory; it must not contain `/'.
444 # If the user is operating on only some files in a directory, only those
445 # files need to be included. This can also be sent without Entry, if there
446 # is no entry for the file.
449 my ( $cmd , $data ) = @_ ;
456 # Grab config information
457 my $blocksize = 8192 ;
458 my $bytesleft = $size ;
461 # Get a filehandle/name to write it to
462 my ( $fh , $filename ) = tempfile
( DIR
=> $TEMP_DIR );
464 # Loop over file data writing out to temporary file.
467 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
468 read STDIN
, $tmp , $blocksize ;
470 $bytesleft -= $blocksize ;
475 # Ensure we have something sensible for the file mode
476 if ( $mode =~ /u=(\w+)/ )
483 # Save the file data in $state
484 $state ->{ entries
}{ $state ->{ directory
}. $data }{ modified_filename
} = $filename ;
485 $state ->{ entries
}{ $state ->{ directory
}. $data }{ modified_mode
} = $mode ;
486 $state ->{ entries
}{ $state ->{ directory
}. $data }{ modified_hash
} = `git-hash-object $filename ` ;
487 $state ->{ entries
}{ $state ->{ directory
}. $data }{ modified_hash
} =~ s/\s.*$//s ;
489 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
492 # Unchanged filename \n
493 # Response expected: no. Tell the server that filename has not been
494 # modified in the checked out directory. The filename is a file within the
495 # most recent directory sent with Directory; it must not contain `/'.
498 my ( $cmd , $data ) = @_ ;
500 $state ->{ entries
}{ $state ->{ directory
}. $data }{ unchanged
} = 1 ;
502 #$log->debug("req_Unchanged : $data");
505 # Questionable filename \n
506 # Response expected: no. Additional data: no.
507 # Tell the server to check whether filename should be ignored,
508 # and if not, next time the server sends responses, send (in
509 # a M response) `?' followed by the directory and filename.
510 # filename must not contain `/'; it needs to be a file in the
511 # directory named by the most recent Directory request.
514 my ( $cmd , $data ) = @_ ;
516 $state ->{ entries
}{ $state ->{ directory
}. $data }{ questionable
} = 1 ;
518 #$log->debug("req_Questionable : $data");
522 # Response expected: no. Save argument for use in a subsequent command.
523 # Arguments accumulate until an argument-using command is given, at which
524 # point they are forgotten.
526 # Response expected: no. Append \n followed by text to the current argument
530 my ( $cmd , $data ) = @_ ;
532 # TODO : Not quite sure how Argument and Argumentx differ, but I assume
533 # it's for multi-line arguments ... somehow ...
535 $log -> debug ( " $cmd : $data " );
537 push @
{ $state ->{ arguments
}}, $data ;
541 # Response expected: yes. Expand the modules which are specified in the
542 # arguments. Returns the data in Module-expansion responses. Note that the
543 # server can assume that this is checkout or export, not rtag or rdiff; the
544 # latter do not access the working directory and thus have no need to
545 # expand modules on the client side. Expand may not be the best word for
546 # what this request does. It does not necessarily tell you all the files
547 # contained in a module, for example. Basically it is a way of telling you
548 # which working directories the server needs to know about in order to
549 # handle a checkout of the specified modules. For example, suppose that the
550 # server has a module defined by
551 # aliasmodule -a 1dir
552 # That is, one can check out aliasmodule and it will take 1dir in the
553 # repository and check it out to 1dir in the working directory. Now suppose
554 # the client already has this module checked out and is planning on using
555 # the co request to update it. Without using expand-modules, the client
556 # would have two bad choices: it could either send information about all
557 # working directories under the current directory, which could be
558 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
559 # stands for 1dir, and neglect to send information for 1dir, which would
560 # lead to incorrect operation. With expand-modules, the client would first
561 # ask for the module to be expanded:
562 sub req_expandmodules
564 my ( $cmd , $data ) = @_ ;
568 $log -> debug ( "req_expandmodules : " . ( defined ( $data ) ?
$data : "[NULL]" ) );
570 unless ( ref $state ->{ arguments
} eq "ARRAY" )
576 foreach my $module ( @
{ $state ->{ arguments
}} )
578 $log -> debug ( "SEND : Module-expansion $module " );
579 print "Module-expansion $module \n " ;
587 # Response expected: yes. Get files from the repository. This uses any
588 # previous Argument, Directory, Entry, or Modified requests, if they have
589 # been sent. Arguments to this command are module names; the client cannot
590 # know what directories they correspond to except by (1) just sending the
591 # co request, and then seeing what directory names the server sends back in
592 # its responses, and (2) the expand-modules request.
595 my ( $cmd , $data ) = @_ ;
599 my $module = $state ->{ args
}[ 0 ];
600 my $checkout_path = $module ;
602 # use the user specified directory if we're given it
603 $checkout_path = $state ->{ opt
}{ d
} if ( exists ( $state ->{ opt
}{ d
} ) );
605 $log -> debug ( "req_co : " . ( defined ( $data ) ?
$data : "[NULL]" ) );
607 $log -> info ( "Checking out module ' $module ' ( $state ->{CVSROOT}) to ' $checkout_path '" );
609 $ENV { GIT_DIR
} = $state ->{ CVSROOT
} . "/" ;
611 # Grab a handle to the SQLite db and do any necessary updates
612 my $updater = GITCVS
:: updater
-> new ( $state ->{ CVSROOT
}, $module , $log );
615 $checkout_path =~ s
|/$||; # get rid of trailing slashes
617 # Eclipse seems to need the Clear-sticky command
618 # to prepare the 'Entries' file for the new directory.
619 print "Clear-sticky $checkout_path / \n " ;
620 print $state ->{ CVSROOT
} . "/ $module / \n " ;
621 print "Clear-static-directory $checkout_path / \n " ;
622 print $state ->{ CVSROOT
} . "/ $module / \n " ;
623 print "Clear-sticky $checkout_path / \n " ; # yes, twice
624 print $state ->{ CVSROOT
} . "/ $module / \n " ;
625 print "Template $checkout_path / \n " ;
626 print $state ->{ CVSROOT
} . "/ $module / \n " ;
629 # instruct the client that we're checking out to $checkout_path
630 print "E cvs checkout: Updating $checkout_path \n " ;
637 my ( $dir , $repodir , $remotedir , $seendirs ) = @_ ;
638 my $parent = dirname
( $dir );
641 $remotedir =~ s
|/+$||;
643 $log -> debug ( "announcedir $dir , $repodir , $remotedir " );
645 if ( $parent eq '.' || $parent eq './' ) {
648 # recurse to announce unseen parents first
649 if ( length ( $parent ) && ! exists ( $seendirs ->{ $parent })) {
650 prepdir
( $parent , $repodir , $remotedir , $seendirs );
652 # Announce that we are going to modify at the parent level
654 print "E cvs checkout: Updating $remotedir / $parent \n " ;
656 print "E cvs checkout: Updating $remotedir \n " ;
658 print "Clear-sticky $remotedir / $parent / \n " ;
659 print " $repodir / $parent / \n " ;
661 print "Clear-static-directory $remotedir / $dir / \n " ;
662 print " $repodir / $dir / \n " ;
663 print "Clear-sticky $remotedir / $parent / \n " ; # yes, twice
664 print " $repodir / $parent / \n " ;
665 print "Template $remotedir / $dir / \n " ;
666 print " $repodir / $dir / \n " ;
669 $seendirs ->{ $dir } = 1 ;
672 foreach my $git ( @
{ $updater -> gethead } )
674 # Don't want to check out deleted files
675 next if ( $git ->{ filehash
} eq "deleted" );
677 ( $git ->{ name
}, $git ->{ dir
} ) = filenamesplit
( $git ->{ name
});
679 if ( length ( $git ->{ dir
}) && $git ->{ dir
} ne './'
680 && $git ->{ dir
} ne $lastdir ) {
681 unless ( exists ( $seendirs { $git ->{ dir
}})) {
682 prepdir
( $git ->{ dir
}, $state ->{ CVSROOT
} . "/ $module /" ,
683 $checkout_path , \
%seendirs );
684 $lastdir = $git ->{ dir
};
685 $seendirs { $git ->{ dir
}} = 1 ;
687 print "E cvs checkout: Updating / $checkout_path / $git ->{dir} \n " ;
690 # modification time of this file
691 print "Mod-time $git ->{modified} \n " ;
693 # print some information to the client
694 if ( defined ( $git ->{ dir
} ) and $git ->{ dir
} ne "./" )
696 print "M U $checkout_path / $git ->{dir} $git ->{name} \n " ;
698 print "M U $checkout_path / $git ->{name} \n " ;
701 # instruct client we're sending a file to put in this path
702 print "Created $checkout_path /" . ( defined ( $git ->{ dir
} ) and $git ->{ dir
} ne "./" ?
$git ->{ dir
} . "/" : "" ) . " \n " ;
704 print $state ->{ CVSROOT
} . "/ $module /" . ( defined ( $git ->{ dir
} ) and $git ->{ dir
} ne "./" ?
$git ->{ dir
} . "/" : "" ) . " $git ->{name} \n " ;
706 # this is an "entries" line
707 print "/ $git ->{name}/1. $git ->{revision}/// \n " ;
709 print "u= $git ->{mode},g= $git ->{mode},o= $git ->{mode} \n " ;
712 transmitfile
( $git ->{ filehash
});
721 # Response expected: yes. Actually do a cvs update command. This uses any
722 # previous Argument, Directory, Entry, or Modified requests, if they have
723 # been sent. The last Directory sent specifies the working directory at the
724 # time of the operation. The -I option is not used--files which the client
725 # can decide whether to ignore are not mentioned and the client sends the
726 # Questionable request for others.
729 my ( $cmd , $data ) = @_ ;
731 $log -> debug ( "req_update : " . ( defined ( $data ) ?
$data : "[NULL]" ));
736 # It may just be a client exploring the available heads/modules
737 # in that case, list them as top level directories and leave it
738 # at that. Eclipse uses this technique to offer you a list of
739 # projects (heads in this case) to checkout.
741 if ( $state ->{ module
} eq '' ) {
742 print "E cvs update: Updating . \n " ;
743 opendir HEADS
, $state ->{ CVSROOT
} . '/refs/heads' ;
744 while ( my $head = readdir ( HEADS
)) {
745 if (- f
$state ->{ CVSROOT
} . '/refs/heads/' . $head ) {
746 print "E cvs update: New directory ` $head ' \n " ;
755 # Grab a handle to the SQLite db and do any necessary updates
756 my $updater = GITCVS
:: updater
-> new ( $state ->{ CVSROOT
}, $state ->{ module
}, $log );
760 # if no files were specified, we need to work out what files we should be providing status on ...
761 argsfromdir
( $updater ) if ( scalar ( @
{ $state ->{ args
}} ) == 0 );
763 #$log->debug("update state : " . Dumper($state));
765 # foreach file specified on the commandline ...
766 foreach my $filename ( @
{ $state ->{ args
}} )
768 $filename = filecleanup
( $filename );
770 # if we have a -C we should pretend we never saw modified stuff
771 if ( exists ( $state ->{ opt
}{ C
} ) )
773 delete $state ->{ entries
}{ $filename }{ modified_hash
};
774 delete $state ->{ entries
}{ $filename }{ modified_filename
};
775 $state ->{ entries
}{ $filename }{ unchanged
} = 1 ;
779 if ( defined ( $state ->{ opt
}{ r
}) and $state ->{ opt
}{ r
} =~ /^1\.(\d+)/ )
781 $meta = $updater -> getmeta ( $filename , $1 );
783 $meta = $updater -> getmeta ( $filename );
786 next unless ( $meta ->{ revision
} );
790 my $wrev = revparse
( $filename );
792 # If the working copy is an old revision, lets get that version too for comparison.
793 if ( defined ( $wrev ) and $wrev != $meta ->{ revision
} )
795 $oldmeta = $updater -> getmeta ( $filename , $wrev );
798 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
800 # Files are up to date if the working copy and repo copy have the same revision,
801 # and the working copy is unmodified _and_ the user hasn't specified -C
802 next if ( defined ( $wrev )
803 and defined ( $meta ->{ revision
})
804 and $wrev == $meta ->{ revision
}
805 and $state ->{ entries
}{ $filename }{ unchanged
}
806 and not exists ( $state ->{ opt
}{ C
} ) );
808 # If the working copy and repo copy have the same revision,
809 # but the working copy is modified, tell the client it's modified
810 if ( defined ( $wrev )
811 and defined ( $meta ->{ revision
})
812 and $wrev == $meta ->{ revision
}
813 and not exists ( $state ->{ opt
}{ C
} ) )
815 $log -> info ( "Tell the client the file is modified" );
817 print "MT fname $filename \n " ;
818 print "MT newline \n " ;
822 if ( $meta ->{ filehash
} eq "deleted" )
824 my ( $filepart , $dirpart ) = filenamesplit
( $filename );
826 $log -> info ( "Removing ' $filename ' from working copy (no longer in the repo)" );
828 print "E cvs update: ` $filename ' is no longer in the repository \n " ;
829 print "Removed $dirpart \n " ;
832 elsif ( not defined ( $state ->{ entries
}{ $filename }{ modified_hash
} )
833 or $state ->{ entries
}{ $filename }{ modified_hash
} eq $oldmeta ->{ filehash
} )
835 $log -> info ( "Updating ' $filename '" );
836 # normal update, just send the new revision (either U=Update, or A=Add, or R=Remove)
837 print "MT +updated \n " ;
839 print "MT fname $filename \n " ;
840 print "MT newline \n " ;
841 print "MT -updated \n " ;
843 my ( $filepart , $dirpart ) = filenamesplit
( $filename );
844 $dirpart =~ s/^$state->{directory}// ;
846 if ( defined ( $wrev ) )
848 # instruct client we're sending a file to put in this path as a replacement
849 print "Update-existing $dirpart \n " ;
850 $log -> debug ( "Updating existing file 'Update-existing $dirpart '" );
852 # instruct client we're sending a file to put in this path as a new file
853 print "Created $dirpart \n " ;
854 $log -> debug ( "Creating new file 'Created $dirpart '" );
856 print $state ->{ CVSROOT
} . "/ $state ->{module}/ $filename \n " ;
858 # this is an "entries" line
859 $log -> debug ( "/ $filepart /1. $meta ->{revision}///" );
860 print "/ $filepart /1. $meta ->{revision}/// \n " ;
863 $log -> debug ( "SEND : u= $meta ->{mode},g= $meta ->{mode},o= $meta ->{mode}" );
864 print "u= $meta ->{mode},g= $meta ->{mode},o= $meta ->{mode} \n " ;
867 transmitfile
( $meta ->{ filehash
});
869 $log -> info ( "Updating ' $filename '" );
870 my ( $filepart , $dirpart ) = filenamesplit
( $meta ->{ name
});
872 my $dir = tempdir
( DIR
=> $TEMP_DIR , CLEANUP
=> 1 ) . "/" ;
875 my $file_local = $filepart . ".mine" ;
876 system ( "ln" , "-s" , $state ->{ entries
}{ $filename }{ modified_filename
}, $file_local );
877 my $file_old = $filepart . "." . $oldmeta ->{ revision
};
878 transmitfile
( $oldmeta ->{ filehash
}, $file_old );
879 my $file_new = $filepart . "." . $meta ->{ revision
};
880 transmitfile
( $meta ->{ filehash
}, $file_new );
882 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
883 $log -> info ( "Merging $file_local , $file_old , $file_new " );
885 $log -> debug ( "Temporary directory for merge is $dir " );
887 my $return = system ( "merge" , $file_local , $file_old , $file_new );
892 $log -> info ( "Merged successfully" );
893 print "M M $filename \n " ;
894 $log -> debug ( "Update-existing $dirpart " );
895 print "Update-existing $dirpart \n " ;
896 $log -> debug ( $state ->{ CVSROOT
} . "/ $state ->{module}/ $filename " );
897 print $state ->{ CVSROOT
} . "/ $state ->{module}/ $filename \n " ;
898 $log -> debug ( "/ $filepart /1. $meta ->{revision}///" );
899 print "/ $filepart /1. $meta ->{revision}/// \n " ;
901 elsif ( $return == 1 )
903 $log -> info ( "Merged with conflicts" );
904 print "M C $filename \n " ;
905 print "Update-existing $dirpart \n " ;
906 print $state ->{ CVSROOT
} . "/ $state ->{module}/ $filename \n " ;
907 print "/ $filepart /1. $meta ->{revision}/+// \n " ;
911 $log -> warn ( "Merge failed" );
916 $log -> debug ( "SEND : u= $meta ->{mode},g= $meta ->{mode},o= $meta ->{mode}" );
917 print "u= $meta ->{mode},g= $meta ->{mode},o= $meta ->{mode} \n " ;
919 # transmit file, format is single integer on a line by itself (file
920 # size) followed by the file contents
921 # TODO : we should copy files in blocks
922 my $data = `cat $file_local ` ;
923 $log -> debug ( "File size : " . length ( $data ));
924 print length ( $data ) . " \n " ;
937 my ( $cmd , $data ) = @_ ;
941 #$log->debug("State : " . Dumper($state));
943 $log -> info ( "req_ci : " . ( defined ( $data ) ?
$data : "[NULL]" ));
945 if ( @ARGV && $ARGV [ 0 ] eq 'pserver' )
947 print "error 1 pserver access cannot commit \n " ;
951 if ( - e
$state ->{ CVSROOT
} . "/index" )
953 $log -> warn ( "file 'index' already exists in the git repository" );
954 print "error 1 Index already exists in git repo \n " ;
958 my $lockfile = " $state ->{CVSROOT}/refs/heads/ $state ->{module}.lock" ;
959 unless ( sysopen ( LOCKFILE
, $lockfile , O_EXCL
| O_CREAT
| O_WRONLY
) )
961 $log -> warn ( "lockfile ' $lockfile ' already exists, please try again" );
962 print "error 1 Lock file ' $lockfile ' already exists, please try again \n " ;
966 # Grab a handle to the SQLite db and do any necessary updates
967 my $updater = GITCVS
:: updater
-> new ( $state ->{ CVSROOT
}, $state ->{ module
}, $log );
970 my $tmpdir = tempdir
( DIR
=> $TEMP_DIR );
971 my ( undef , $file_index ) = tempfile
( DIR
=> $TEMP_DIR , OPEN
=> 0 );
972 $log -> info ( "Lock successful, basing commit on ' $tmpdir ', index file is ' $file_index '" );
974 $ENV { GIT_DIR
} = $state ->{ CVSROOT
} . "/" ;
975 $ENV { GIT_INDEX_FILE
} = $file_index ;
979 # populate the temporary index based
980 system ( "git-read-tree" , $state ->{ module
});
983 die "Error running git-read-tree $state ->{module} $file_index $!" ;
985 $log -> info ( "Created index ' $file_index ' with for head $state ->{module} - exit status $?" );
988 my @committedfiles = ();
990 # foreach file specified on the commandline ...
991 foreach my $filename ( @
{ $state ->{ args
}} )
993 $filename = filecleanup
( $filename );
995 next unless ( exists $state ->{ entries
}{ $filename }{ modified_filename
} or not $state ->{ entries
}{ $filename }{ unchanged
} );
997 my $meta = $updater -> getmeta ( $filename );
999 my $wrev = revparse
( $filename );
1001 my ( $filepart , $dirpart ) = filenamesplit
( $filename );
1003 # do a checkout of the file if it part of this tree
1005 system ( 'git-checkout-index' , '-f' , '-u' , $filename );
1007 die "Error running git-checkout-index -f -u $filename : $!" ;
1013 $rmflag = 1 if ( defined ( $wrev ) and $wrev < 0 );
1014 $addflag = 1 unless ( - e
$filename );
1016 # Do up to date checking
1017 unless ( $addflag or $wrev == $meta ->{ revision
} or ( $rmflag and - $wrev == $meta ->{ revision
} ) )
1019 # fail everything if an up to date check fails
1020 print "error 1 Up to date check failed for $filename \n " ;
1027 push @committedfiles , $filename ;
1028 $log -> info ( "Committing $filename " );
1030 system ( "mkdir" , "-p" , $dirpart ) unless ( - d
$dirpart );
1034 $log -> debug ( "rename $state ->{entries}{ $filename }{modified_filename} $filename " );
1035 rename $state ->{ entries
}{ $filename }{ modified_filename
}, $filename ;
1037 # Calculate modes to remove
1039 foreach ( qw
( r w x
) ) { $invmode .= $_ unless ( $state ->{ entries
}{ $filename }{ modified_mode
} =~ /$_/ ); }
1041 $log -> debug ( "chmod u+" . $state ->{ entries
}{ $filename }{ modified_mode
} . "-" . $invmode . " $filename " );
1042 system ( "chmod" , "u+" . $state ->{ entries
}{ $filename }{ modified_mode
} . "-" . $invmode , $filename );
1047 $log -> info ( "Removing file ' $filename '" );
1049 system ( "git-update-index" , "--remove" , $filename );
1053 $log -> info ( "Adding file ' $filename '" );
1054 system ( "git-update-index" , "--add" , $filename );
1056 $log -> info ( "Updating file ' $filename '" );
1057 system ( "git-update-index" , $filename );
1061 unless ( scalar ( @committedfiles ) > 0 )
1063 print "E No files to commit \n " ;
1071 my $treehash = `git-write-tree` ;
1072 my $parenthash = `cat $ENV {GIT_DIR}refs/heads/ $state ->{module}` ;
1076 $log -> debug ( "Treehash : $treehash , Parenthash : $parenthash " );
1078 # write our commit message out if we have one ...
1079 my ( $msg_fh , $msg_filename ) = tempfile
( DIR
=> $TEMP_DIR );
1080 print $msg_fh $state ->{ opt
}{ m
}; # if ( exists ( $state->{opt}{m} ) );
1081 print $msg_fh " \n\n via git-CVS emulator \n " ;
1084 my $commithash = `git-commit-tree $treehash -p $parenthash < $msg_filename ` ;
1085 $log -> info ( "Commit hash : $commithash " );
1087 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1089 $log -> warn ( "Commit failed (Invalid commit hash)" );
1090 print "error 1 Commit failed (unknown reason) \n " ;
1097 open FILE
, ">" , " $ENV {GIT_DIR}refs/heads/ $state ->{module}" ;
1098 print FILE
$commithash ;
1103 # foreach file specified on the commandline ...
1104 foreach my $filename ( @committedfiles )
1106 $filename = filecleanup
( $filename );
1108 my $meta = $updater -> getmeta ( $filename );
1110 my ( $filepart , $dirpart ) = filenamesplit
( $filename );
1112 $log -> debug ( "Checked-in $dirpart : $filename " );
1114 if ( $meta ->{ filehash
} eq "deleted" )
1116 print "Remove-entry $dirpart \n " ;
1117 print " $filename \n " ;
1119 print "Checked-in $dirpart \n " ;
1120 print " $filename \n " ;
1121 print "/ $filepart /1. $meta ->{revision}/// \n " ;
1134 my ( $cmd , $data ) = @_ ;
1138 $log -> info ( "req_status : " . ( defined ( $data ) ?
$data : "[NULL]" ));
1139 #$log->debug("status state : " . Dumper($state));
1141 # Grab a handle to the SQLite db and do any necessary updates
1142 my $updater = GITCVS
:: updater
-> new ( $state ->{ CVSROOT
}, $state ->{ module
}, $log );
1145 # if no files were specified, we need to work out what files we should be providing status on ...
1146 argsfromdir
( $updater ) if ( scalar ( @
{ $state ->{ args
}} ) == 0 );
1148 # foreach file specified on the commandline ...
1149 foreach my $filename ( @
{ $state ->{ args
}} )
1151 $filename = filecleanup
( $filename );
1153 my $meta = $updater -> getmeta ( $filename );
1154 my $oldmeta = $meta ;
1156 my $wrev = revparse
( $filename );
1158 # If the working copy is an old revision, lets get that version too for comparison.
1159 if ( defined ( $wrev ) and $wrev != $meta ->{ revision
} )
1161 $oldmeta = $updater -> getmeta ( $filename , $wrev );
1164 # TODO : All possible statuses aren't yet implemented
1166 # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1167 $status = "Up-to-date" if ( defined ( $wrev ) and defined ( $meta ->{ revision
}) and $wrev == $meta ->{ revision
}
1169 ( ( $state ->{ entries
}{ $filename }{ unchanged
} and ( not defined ( $state ->{ entries
}{ $filename }{ conflict
} ) or $state ->{ entries
}{ $filename }{ conflict
} !~ /^\+=/ ) )
1170 or ( defined ( $state ->{ entries
}{ $filename }{ modified_hash
}) and $state ->{ entries
}{ $filename }{ modified_hash
} eq $meta ->{ filehash
} ) )
1173 # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1174 $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta ->{ revision
} ) and $meta ->{ revision
} > $wrev
1176 ( $state ->{ entries
}{ $filename }{ unchanged
}
1177 or ( defined ( $state ->{ entries
}{ $filename }{ modified_hash
}) and $state ->{ entries
}{ $filename }{ modified_hash
} eq $oldmeta ->{ filehash
} ) )
1180 # Need checkout if it exists in the repo but doesn't have a working copy
1181 $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta ->{ revision
} ) );
1183 # Locally modified if working copy and repo copy have the same revision but there are local changes
1184 $status ||= "Locally Modified" if ( defined ( $wrev ) and defined ( $meta ->{ revision
}) and $wrev == $meta ->{ revision
} and $state ->{ entries
}{ $filename }{ modified_filename
} );
1186 # Needs Merge if working copy revision is less than repo copy and there are local changes
1187 $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta ->{ revision
} ) and $meta ->{ revision
} > $wrev and $state ->{ entries
}{ $filename }{ modified_filename
} );
1189 $status ||= "Locally Added" if ( defined ( $state ->{ entries
}{ $filename }{ revision
} ) and not defined ( $meta ->{ revision
} ) );
1190 $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta ->{ revision
} ) and - $wrev == $meta ->{ revision
} );
1191 $status ||= "Unresolved Conflict" if ( defined ( $state ->{ entries
}{ $filename }{ conflict
} ) and $state ->{ entries
}{ $filename }{ conflict
} =~ /^\+=/ );
1192 $status ||= "File had conflicts on merge" if ( 0 );
1194 $status ||= "Unknown" ;
1196 print "M =================================================================== \n " ;
1197 print "M File: $filename \t Status: $status \n " ;
1198 if ( defined ( $state ->{ entries
}{ $filename }{ revision
}) )
1200 print "M Working revision: \t " . $state ->{ entries
}{ $filename }{ revision
} . " \n " ;
1202 print "M Working revision: \t No entry for $filename \n " ;
1204 if ( defined ( $meta ->{ revision
}) )
1206 print "M Repository revision: \t 1." . $meta ->{ revision
} . " \t $state ->{repository}/ $filename ,v \n " ;
1207 print "M Sticky Tag: \t\t (none) \n " ;
1208 print "M Sticky Date: \t\t (none) \n " ;
1209 print "M Sticky Options: \t\t (none) \n " ;
1211 print "M Repository revision: \t No revision control file \n " ;
1221 my ( $cmd , $data ) = @_ ;
1225 $log -> debug ( "req_diff : " . ( defined ( $data ) ?
$data : "[NULL]" ));
1226 #$log->debug("status state : " . Dumper($state));
1228 my ( $revision1 , $revision2 );
1229 if ( defined ( $state ->{ opt
}{ r
} ) and ref $state ->{ opt
}{ r
} eq "ARRAY" )
1231 $revision1 = $state ->{ opt
}{ r
}[ 0 ];
1232 $revision2 = $state ->{ opt
}{ r
}[ 1 ];
1234 $revision1 = $state ->{ opt
}{ r
};
1237 $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1238 $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1240 $log -> debug ( "Diffing revisions " . ( defined ( $revision1 ) ?
$revision1 : "[NULL]" ) . " and " . ( defined ( $revision2 ) ?
$revision2 : "[NULL]" ) );
1242 # Grab a handle to the SQLite db and do any necessary updates
1243 my $updater = GITCVS
:: updater
-> new ( $state ->{ CVSROOT
}, $state ->{ module
}, $log );
1246 # if no files were specified, we need to work out what files we should be providing status on ...
1247 argsfromdir
( $updater ) if ( scalar ( @
{ $state ->{ args
}} ) == 0 );
1249 # foreach file specified on the commandline ...
1250 foreach my $filename ( @
{ $state ->{ args
}} )
1252 $filename = filecleanup
( $filename );
1254 my ( $fh , $file1 , $file2 , $meta1 , $meta2 , $filediff );
1256 my $wrev = revparse
( $filename );
1258 # We need _something_ to diff against
1259 next unless ( defined ( $wrev ) );
1261 # if we have a -r switch, use it
1262 if ( defined ( $revision1 ) )
1264 ( undef , $file1 ) = tempfile
( DIR
=> $TEMP_DIR , OPEN
=> 0 );
1265 $meta1 = $updater -> getmeta ( $filename , $revision1 );
1266 unless ( defined ( $meta1 ) and $meta1 ->{ filehash
} ne "deleted" )
1268 print "E File $filename at revision 1. $revision1 doesn't exist \n " ;
1271 transmitfile
( $meta1 ->{ filehash
}, $file1 );
1273 # otherwise we just use the working copy revision
1276 ( undef , $file1 ) = tempfile
( DIR
=> $TEMP_DIR , OPEN
=> 0 );
1277 $meta1 = $updater -> getmeta ( $filename , $wrev );
1278 transmitfile
( $meta1 ->{ filehash
}, $file1 );
1281 # if we have a second -r switch, use it too
1282 if ( defined ( $revision2 ) )
1284 ( undef , $file2 ) = tempfile
( DIR
=> $TEMP_DIR , OPEN
=> 0 );
1285 $meta2 = $updater -> getmeta ( $filename , $revision2 );
1287 unless ( defined ( $meta2 ) and $meta2 ->{ filehash
} ne "deleted" )
1289 print "E File $filename at revision 1. $revision2 doesn't exist \n " ;
1293 transmitfile
( $meta2 ->{ filehash
}, $file2 );
1295 # otherwise we just use the working copy
1298 $file2 = $state ->{ entries
}{ $filename }{ modified_filename
};
1301 # if we have been given -r, and we don't have a $file2 yet, lets get one
1302 if ( defined ( $revision1 ) and not defined ( $file2 ) )
1304 ( undef , $file2 ) = tempfile
( DIR
=> $TEMP_DIR , OPEN
=> 0 );
1305 $meta2 = $updater -> getmeta ( $filename , $wrev );
1306 transmitfile
( $meta2 ->{ filehash
}, $file2 );
1309 # We need to have retrieved something useful
1310 next unless ( defined ( $meta1 ) );
1312 # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1313 next if ( not defined ( $meta2 ) and $wrev == $meta1 ->{ revision
}
1315 ( ( $state ->{ entries
}{ $filename }{ unchanged
} and ( not defined ( $state ->{ entries
}{ $filename }{ conflict
} ) or $state ->{ entries
}{ $filename }{ conflict
} !~ /^\+=/ ) )
1316 or ( defined ( $state ->{ entries
}{ $filename }{ modified_hash
}) and $state ->{ entries
}{ $filename }{ modified_hash
} eq $meta1 ->{ filehash
} ) )
1319 # Apparently we only show diffs for locally modified files
1320 next unless ( defined ( $meta2 ) or defined ( $state ->{ entries
}{ $filename }{ modified_filename
} ) );
1322 print "M Index: $filename \n " ;
1323 print "M =================================================================== \n " ;
1324 print "M RCS file: $state ->{CVSROOT}/ $state ->{module}/ $filename ,v \n " ;
1325 print "M retrieving revision 1. $meta1 ->{revision} \n " if ( defined ( $meta1 ) );
1326 print "M retrieving revision 1. $meta2 ->{revision} \n " if ( defined ( $meta2 ) );
1328 foreach my $opt ( keys %{ $state ->{ opt
}} )
1330 if ( ref $state ->{ opt
}{ $opt } eq "ARRAY" )
1332 foreach my $value ( @
{ $state ->{ opt
}{ $opt }} )
1334 print "- $opt $value " ;
1338 print " $state ->{opt}{ $opt } " if ( defined ( $state ->{ opt
}{ $opt } ) );
1341 print " $filename \n " ;
1343 $log -> info ( "Diffing $filename -r $meta1 ->{revision} -r " . ( $meta2 ->{ revision
} or "workingcopy" ));
1345 ( $fh , $filediff ) = tempfile
( DIR
=> $TEMP_DIR );
1347 if ( exists $state ->{ opt
}{ u
} )
1349 system ( "diff -u -L ' $filename revision 1. $meta1 ->{revision}' -L ' $filename " . ( defined ( $meta2 ->{ revision
}) ?
"revision 1. $meta2 ->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff " );
1351 system ( "diff $file1 $file2 > $filediff " );
1366 my ( $cmd , $data ) = @_ ;
1370 $log -> debug ( "req_log : " . ( defined ( $data ) ?
$data : "[NULL]" ));
1371 #$log->debug("log state : " . Dumper($state));
1373 my ( $minrev , $maxrev );
1374 if ( defined ( $state ->{ opt
}{ r
} ) and $state ->{ opt
}{ r
} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1379 $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1380 $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1381 $minrev ++ if ( defined ( $minrev ) and $control eq "::" );
1384 # Grab a handle to the SQLite db and do any necessary updates
1385 my $updater = GITCVS
:: updater
-> new ( $state ->{ CVSROOT
}, $state ->{ module
}, $log );
1388 # if no files were specified, we need to work out what files we should be providing status on ...
1389 argsfromdir
( $updater ) if ( scalar ( @
{ $state ->{ args
}} ) == 0 );
1391 # foreach file specified on the commandline ...
1392 foreach my $filename ( @
{ $state ->{ args
}} )
1394 $filename = filecleanup
( $filename );
1396 my $headmeta = $updater -> getmeta ( $filename );
1398 my $revisions = $updater -> getlog ( $filename );
1399 my $totalrevisions = scalar ( @
$revisions );
1401 if ( defined ( $minrev ) )
1403 $log -> debug ( "Removing revisions less than $minrev " );
1404 while ( scalar ( @
$revisions ) > 0 and $revisions ->[- 1 ]{ revision
} < $minrev )
1409 if ( defined ( $maxrev ) )
1411 $log -> debug ( "Removing revisions greater than $maxrev " );
1412 while ( scalar ( @
$revisions ) > 0 and $revisions ->[ 0 ]{ revision
} > $maxrev )
1418 next unless ( scalar ( @
$revisions ) );
1421 print "M RCS file: $state ->{CVSROOT}/ $state ->{module}/ $filename ,v \n " ;
1422 print "M Working file: $filename \n " ;
1423 print "M head: 1. $headmeta ->{revision} \n " ;
1424 print "M branch: \n " ;
1425 print "M locks: strict \n " ;
1426 print "M access list: \n " ;
1427 print "M symbolic names: \n " ;
1428 print "M keyword substitution: kv \n " ;
1429 print "M total revisions: $totalrevisions ; \t selected revisions: " . scalar ( @
$revisions ) . " \n " ;
1430 print "M description: \n " ;
1432 foreach my $revision ( @
$revisions )
1434 print "M ---------------------------- \n " ;
1435 print "M revision 1. $revision ->{revision} \n " ;
1436 # reformat the date for log output
1437 $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 }) );
1438 $revision ->{ author
} =~ s/\s+.*// ;
1439 $revision ->{ author
} =~ s/^(.{8}).*/$1/ ;
1440 print "M date: $revision ->{modified}; author: $revision ->{author}; state: " . ( $revision ->{ filehash
} eq "deleted" ?
"dead" : "Exp" ) . "; lines: +2 -3 \n " ;
1441 my $commitmessage = $updater -> commitmessage ( $revision ->{ commithash
});
1442 $commitmessage =~ s/^/M /mg ;
1443 print $commitmessage . " \n " ;
1445 print "M ============================================================================= \n " ;
1453 my ( $cmd , $data ) = @_ ;
1455 argsplit
( "annotate" );
1457 $log -> info ( "req_annotate : " . ( defined ( $data ) ?
$data : "[NULL]" ));
1458 #$log->debug("status state : " . Dumper($state));
1460 # Grab a handle to the SQLite db and do any necessary updates
1461 my $updater = GITCVS
:: updater
-> new ( $state ->{ CVSROOT
}, $state ->{ module
}, $log );
1464 # if no files were specified, we need to work out what files we should be providing annotate on ...
1465 argsfromdir
( $updater ) if ( scalar ( @
{ $state ->{ args
}} ) == 0 );
1467 # we'll need a temporary checkout dir
1468 my $tmpdir = tempdir
( DIR
=> $TEMP_DIR );
1469 my ( undef , $file_index ) = tempfile
( DIR
=> $TEMP_DIR , OPEN
=> 0 );
1470 $log -> info ( "Temp checkoutdir creation successful, basing annotate session work on ' $tmpdir ', index file is ' $file_index '" );
1472 $ENV { GIT_DIR
} = $state ->{ CVSROOT
} . "/" ;
1473 $ENV { GIT_INDEX_FILE
} = $file_index ;
1477 # foreach file specified on the commandline ...
1478 foreach my $filename ( @
{ $state ->{ args
}} )
1480 $filename = filecleanup
( $filename );
1482 my $meta = $updater -> getmeta ( $filename );
1484 next unless ( $meta ->{ revision
} );
1486 # get all the commits that this file was in
1487 # in dense format -- aka skip dead revisions
1488 my $revisions = $updater -> gethistorydense ( $filename );
1489 my $lastseenin = $revisions ->[ 0 ][ 2 ];
1491 # populate the temporary index based on the latest commit were we saw
1492 # the file -- but do it cheaply without checking out any files
1493 # TODO: if we got a revision from the client, use that instead
1494 # to look up the commithash in sqlite (still good to default to
1495 # the current head as we do now)
1496 system ( "git-read-tree" , $lastseenin );
1499 die "Error running git-read-tree $lastseenin $file_index $!" ;
1501 $log -> info ( "Created index ' $file_index ' with commit $lastseenin - exit status $?" );
1503 # do a checkout of the file
1504 system ( 'git-checkout-index' , '-f' , '-u' , $filename );
1506 die "Error running git-checkout-index -f -u $filename : $!" ;
1509 $log -> info ( "Annotate $filename " );
1511 # Prepare a file with the commits from the linearized
1512 # history that annotate should know about. This prevents
1513 # git-jsannotate telling us about commits we are hiding
1516 open ( ANNOTATEHINTS
, "> $tmpdir /.annotate_hints" ) or die "Error opening > $tmpdir /.annotate_hints $!" ;
1517 for ( my $i = 0 ; $i < @
$revisions ; $i ++)
1519 print ANNOTATEHINTS
$revisions ->[ $i ][ 2 ];
1520 if ( $i + 1 < @
$revisions ) { # have we got a parent?
1521 print ANNOTATEHINTS
' ' . $revisions ->[ $i + 1 ][ 2 ];
1523 print ANNOTATEHINTS
" \n " ;
1526 print ANNOTATEHINTS
" \n " ;
1527 close ANNOTATEHINTS
;
1529 my $annotatecmd = 'git-annotate' ;
1530 open ( ANNOTATE
, "-|" , $annotatecmd , '-l' , '-S' , " $tmpdir /.annotate_hints" , $filename )
1531 or die "Error invoking $annotatecmd -l -S $tmpdir /.annotate_hints $filename : $!" ;
1533 print "E Annotations for $filename \n " ;
1534 print "E *************** \n " ;
1535 while ( < ANNOTATE
> )
1537 if ( m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i )
1539 my $commithash = $1 ;
1541 unless ( defined ( $metadata ->{ $commithash } ) )
1543 $metadata ->{ $commithash } = $updater -> getmeta ( $filename , $commithash );
1544 $metadata ->{ $commithash }{ author
} =~ s/\s+.*// ;
1545 $metadata ->{ $commithash }{ author
} =~ s/^(.{8}).*/$1/ ;
1546 $metadata ->{ $commithash }{ modified
} = sprintf ( " %02d - %s - %02d " , $1 , $2 , $3 ) if ( $metadata ->{ $commithash }{ modified
} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1548 printf ( "M 1.%-5d (%-8s %10s ): %s \n " ,
1549 $metadata ->{ $commithash }{ revision
},
1550 $metadata ->{ $commithash }{ author
},
1551 $metadata ->{ $commithash }{ modified
},
1555 $log -> warn ( "Error in annotate output! LINE: $_ " );
1556 print "E Annotate error \n " ;
1563 # done; get out of the tempdir
1570 # This method takes the state->{arguments} array and produces two new arrays.
1571 # The first is $state->{args} which is everything before the '--' argument, and
1572 # the second is $state->{files} which is everything after it.
1575 return unless ( defined ( $state ->{ arguments
}) and ref $state ->{ arguments
} eq "ARRAY" );
1579 $state ->{ args
} = [];
1580 $state ->{ files
} = [];
1583 if ( defined ( $type ) )
1586 $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" );
1587 $opt = { v
=> 0 , l
=> 0 , R
=> 0 } if ( $type eq "status" );
1588 $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" );
1589 $opt = { l
=> 0 , R
=> 0 , k
=> 1 , D
=> 1 , D
=> 1 , r
=> 2 } if ( $type eq "diff" );
1590 $opt = { c
=> 0 , R
=> 0 , l
=> 0 , f
=> 0 , F
=> 1 , m
=> 1 , r
=> 1 } if ( $type eq "ci" );
1591 $opt = { k
=> 1 , m
=> 1 } if ( $type eq "add" );
1592 $opt = { f
=> 0 , l
=> 0 , R
=> 0 } if ( $type eq "remove" );
1593 $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" );
1596 while ( scalar ( @
{ $state ->{ arguments
}} ) > 0 )
1598 my $arg = shift @
{ $state ->{ arguments
}};
1600 next if ( $arg eq "--" );
1601 next unless ( $arg =~ /\S/ );
1603 # if the argument looks like a switch
1604 if ( $arg =~ /^-(\w)(.*)/ )
1606 # if it's a switch that takes an argument
1609 # If this switch has already been provided
1610 if ( $opt ->{ $1 } > 1 and exists ( $state ->{ opt
}{ $1 } ) )
1612 $state ->{ opt
}{ $1 } = [ $state ->{ opt
}{ $1 } ];
1613 if ( length ( $2 ) > 0 )
1615 push @
{ $state ->{ opt
}{ $1 }}, $2 ;
1617 push @
{ $state ->{ opt
}{ $1 }}, shift @
{ $state ->{ arguments
}};
1620 # if there's extra data in the arg, use that as the argument for the switch
1621 if ( length ( $2 ) > 0 )
1623 $state ->{ opt
}{ $1 } = $2 ;
1625 $state ->{ opt
}{ $1 } = shift @
{ $state ->{ arguments
}};
1629 $state ->{ opt
}{ $1 } = undef ;
1634 push @
{ $state ->{ args
}}, $arg ;
1642 foreach my $value ( @
{ $state ->{ arguments
}} )
1644 if ( $value eq "--" )
1649 push @
{ $state ->{ args
}}, $value if ( $mode == 0 );
1650 push @
{ $state ->{ files
}}, $value if ( $mode == 1 );
1655 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
1658 my $updater = shift ;
1660 $state ->{ args
} = [];
1662 foreach my $file ( @
{ $updater -> gethead } )
1664 next if ( $file ->{ filehash
} eq "deleted" and not defined ( $state ->{ entries
}{ $file ->{ name
}} ) );
1665 next unless ( $file ->{ name
} =~ s/^$state->{directory}// );
1666 push @
{ $state ->{ args
}}, $file ->{ name
};
1670 # This method cleans up the $state variable after a command that uses arguments has run
1673 $state ->{ files
} = [];
1674 $state ->{ args
} = [];
1675 $state ->{ arguments
} = [];
1676 $state ->{ entries
} = {};
1681 my $filename = shift ;
1683 return undef unless ( defined ( $state ->{ entries
}{ $filename }{ revision
} ) );
1685 return $1 if ( $state ->{ entries
}{ $filename }{ revision
} =~ /^1\.(\d+)/ );
1686 return - $1 if ( $state ->{ entries
}{ $filename }{ revision
} =~ /^-1\.(\d+)/ );
1691 # This method takes a file hash and does a CVS "file transfer" which transmits the
1692 # size of the file, and then the file contents.
1693 # If a second argument $targetfile is given, the file is instead written out to
1694 # a file by the name of $targetfile
1697 my $filehash = shift ;
1698 my $targetfile = shift ;
1700 if ( defined ( $filehash ) and $filehash eq "deleted" )
1702 $log -> warn ( "filehash is 'deleted'" );
1706 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
1708 my $type = `git-cat-file -t $filehash ` ;
1711 die ( "Invalid type ' $type ' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
1713 my $size = `git-cat-file -s $filehash ` ;
1716 $log -> debug ( "transmitfile( $filehash ) size= $size , type= $type " );
1718 if ( open my $fh , '-|' , "git-cat-file" , "blob" , $filehash )
1720 if ( defined ( $targetfile ) )
1722 open NEWFILE
, ">" , $targetfile or die ( "Couldn't open ' $targetfile ' for writing : $!" );
1723 print NEWFILE
$_ while ( < $fh > );
1727 print while ( < $fh > );
1729 close $fh or die ( "Couldn't close filehandle for transmitfile()" );
1731 die ( "Couldn't execute git-cat-file" );
1735 # This method takes a file name, and returns ( $dirpart, $filepart ) which
1736 # refers to the directory portion and the file portion of the filename
1740 my $filename = shift ;
1742 my ( $filepart , $dirpart ) = ( $filename , "." );
1743 ( $filepart , $dirpart ) = ( $2 , $1 ) if ( $filename =~ /(.*)\/ (.*)/ );
1746 return ( $filepart , $dirpart );
1751 my $filename = shift ;
1753 return undef unless ( defined ( $filename ));
1754 if ( $filename =~ /^\/ / )
1756 print "E absolute filenames ' $filename ' not supported by server \n " ;
1760 $filename =~ s/^\.\// / g
;
1761 $filename = $state ->{ directory
} . $filename ;
1766 package GITCVS
:: log ;
1769 #### Copyright The Open University UK - 2006.
1771 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
1772 #### Martin Langhoff <martin@catalyst.net.nz>
1785 This module provides very crude logging with a similar interface to
1794 Creates a new log object, optionally you can specify a filename here to
1795 indicate the file to log to. If no log file is specified, you can specify one
1796 later with method setfile, or indicate you no longer want logging with method
1799 Until one of these methods is called, all log calls will buffer messages ready
1806 my $filename = shift ;
1810 bless $self , $class ;
1812 if ( defined ( $filename ) )
1814 open $self ->{ fh
}, ">>" , $filename or die ( "Couldn't open ' $filename ' for writing : $!" );
1822 This methods takes a filename, and attempts to open that file as the log file.
1823 If successful, all buffered data is written out to the file, and any further
1824 logging is written directly to the file.
1830 my $filename = shift ;
1832 if ( defined ( $filename ) )
1834 open $self ->{ fh
}, ">>" , $filename or die ( "Couldn't open ' $filename ' for writing : $!" );
1837 return unless ( defined ( $self ->{ buffer
} ) and ref $self ->{ buffer
} eq "ARRAY" );
1839 while ( my $line = shift @
{ $self ->{ buffer
}} )
1841 print { $self ->{ fh
}} $line ;
1847 This method indicates no logging is going to be used. It flushes any entries in
1848 the internal buffer, and sets a flag to ensure no further data is put there.
1857 return unless ( defined ( $self ->{ buffer
} ) and ref $self ->{ buffer
} eq "ARRAY" );
1859 $self ->{ buffer
} = [];
1864 Internal method. Returns true if the log file is open, false otherwise.
1871 return 1 if ( defined ( $self ->{ fh
} ) and ref $self ->{ fh
} eq "GLOB" );
1875 =head2 debug info warn fatal
1877 These four methods are wrappers to _log. They provide the actual interface for
1881 sub debug
{ my $self = shift ; $self -> _log ( "debug" , @_ ); }
1882 sub info
{ my $self = shift ; $self -> _log ( "info" , @_ ); }
1883 sub warn { my $self = shift ; $self -> _log ( "warn" , @_ ); }
1884 sub fatal
{ my $self = shift ; $self -> _log ( "fatal" , @_ ); }
1888 This is an internal method called by the logging functions. It generates a
1889 timestamp and pushes the logged line either to file, or internal buffer.
1897 return if ( $self ->{ nolog
} );
1899 my @time = localtime ;
1900 my $timestring = sprintf ( " %4d - %02d - %02d %02d : %02d : %02d : %-5s" ,
1910 if ( $self -> _logopen )
1912 print { $self ->{ fh
}} $timestring . " - " . join ( " " , @_ ) . " \n " ;
1914 push @
{ $self ->{ buffer
}}, $timestring . " - " . join ( " " , @_ ) . " \n " ;
1920 This method simply closes the file handle if one is open
1927 if ( $self -> _logopen )
1933 package GITCVS
:: updater
;
1936 #### Copyright The Open University UK - 2006.
1938 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
1939 #### Martin Langhoff <martin@catalyst.net.nz>
1961 die "Need to specify a git repository" unless ( defined ( $config ) and - d
$config );
1962 die "Need to specify a module" unless ( defined ( $module ) );
1964 $class = ref ( $class ) || $class ;
1968 bless $self , $class ;
1970 $self ->{ dbdir
} = $config . "/" ;
1971 die "Database dir ' $self ->{dbdir}' isn't a directory" unless ( defined ( $self ->{ dbdir
}) and - d
$self ->{ dbdir
} );
1973 $self ->{ module
} = $module ;
1974 $self ->{ file
} = $self ->{ dbdir
} . "/gitcvs. $module .sqlite" ;
1976 $self ->{ git_path
} = $config . "/" ;
1978 $self ->{ log } = $log ;
1980 die "Git repo ' $self ->{git_path}' doesn't exist" unless ( - d
$self ->{ git_path
} );
1982 $self ->{ dbh
} = DBI
-> connect ( "dbi:SQLite:dbname=" . $self ->{ file
}, "" , "" );
1984 $self ->{ tables
} = {};
1985 foreach my $table ( $self ->{ dbh
}-> tables )
1989 $self ->{ tables
}{ $table } = 1 ;
1992 # Construct the revision table if required
1993 unless ( $self ->{ tables
}{ revision
} )
1996 CREATE TABLE revision (
1998 revision INTEGER NOT NULL,
1999 filehash TEXT NOT NULL,
2000 commithash TEXT NOT NULL,
2001 author TEXT NOT NULL,
2002 modified TEXT NOT NULL,
2008 # Construct the revision table if required
2009 unless ( $self ->{ tables
}{ head
} )
2014 revision INTEGER NOT NULL,
2015 filehash TEXT NOT NULL,
2016 commithash TEXT NOT NULL,
2017 author TEXT NOT NULL,
2018 modified TEXT NOT NULL,
2024 # Construct the properties table if required
2025 unless ( $self ->{ tables
}{ properties
} )
2028 CREATE TABLE properties (
2029 key TEXT NOT NULL PRIMARY KEY,
2035 # Construct the commitmsgs table if required
2036 unless ( $self ->{ tables
}{ commitmsgs
} )
2039 CREATE TABLE commitmsgs (
2040 key TEXT NOT NULL PRIMARY KEY,
2056 # first lets get the commit list
2057 $ENV { GIT_DIR
} = $self ->{ git_path
};
2059 # prepare database queries
2060 my $db_insert_rev = $self ->{ dbh
}-> prepare_cached ( "INSERT INTO revision (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)" ,{}, 1 );
2061 my $db_insert_mergelog = $self ->{ dbh
}-> prepare_cached ( "INSERT INTO commitmsgs (key, value) VALUES (?,?)" ,{}, 1 );
2062 my $db_delete_head = $self ->{ dbh
}-> prepare_cached ( "DELETE FROM head" ,{}, 1 );
2063 my $db_insert_head = $self ->{ dbh
}-> prepare_cached ( "INSERT INTO head (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)" ,{}, 1 );
2065 my $commitinfo = `git-cat-file commit $self ->{module} 2>&1` ;
2066 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
2068 die ( "Invalid module ' $self ->{module}'" );
2073 my $lastcommit = $self -> _get_prop ( "last_commit" );
2075 # Start exclusive lock here...
2076 $self ->{ dbh
}-> begin_work () or die "Cannot lock database for BEGIN" ;
2078 # TODO: log processing is memory bound
2079 # if we can parse into a 2nd file that is in reverse order
2080 # we can probably do something really efficient
2081 my @git_log_params = ( '--pretty' , '--parents' , '--topo-order' );
2083 if ( defined $lastcommit ) {
2084 push @git_log_params , " $lastcommit .. $self ->{module}" ;
2086 push @git_log_params , $self ->{ module
};
2088 # git-rev-list is the backend / plumbing version of git-log
2089 open ( GITLOG
, '-|' , 'git-rev-list' , @git_log_params ) or die "Cannot call git-rev-list: $!" ;
2098 if ( m/^commit\s+(.*)$/ ) {
2099 # on ^commit lines put the just seen commit in the stack
2100 # and prime things for the next one
2103 unshift @commits , \
%copy ;
2106 my @parents = split ( m/\s+/ , $1 );
2107 $commit { hash
} = shift @parents ;
2108 $commit { parents
} = \
@parents ;
2109 } elsif ( m/^(\w+?):\s+(.*)$/ && ! exists ( $commit { message
})) {
2110 # on rfc822-like lines seen before we see any message,
2111 # lowercase the entry and put it in the hash as key-value
2112 $commit { lc ( $1 )} = $2 ;
2114 # message lines - skip initial empty line
2115 # and trim whitespace
2116 if (! exists ( $commit { message
}) && m/^\s*$/ ) {
2117 # define it to mark the end of headers
2118 $commit { message
} = '' ;
2121 s/^\s+// ; s/\s+$// ; # trim ws
2122 $commit { message
} .= $_ . " \n " ;
2127 unshift @commits , \
%commit if ( keys %commit );
2129 # Now all the commits are in the @commits bucket
2130 # ordered by time DESC. for each commit that needs processing,
2131 # determine whether it's following the last head we've seen or if
2132 # it's on its own branch, grab a file list, and add whatever's changed
2133 # NOTE: $lastcommit refers to the last commit from previous run
2134 # $lastpicked is the last commit we picked in this run
2137 if ( defined $lastcommit ) {
2138 $lastpicked = $lastcommit ;
2141 my $committotal = scalar ( @commits );
2142 my $commitcount = 0 ;
2144 # Load the head table into $head (for cached lookups during the update process)
2145 foreach my $file ( @
{ $self -> gethead ()} )
2147 $head ->{ $file ->{ name
}} = $file ;
2150 foreach my $commit ( @commits )
2152 $self ->{ log }-> debug ( "GITCVS::updater - Processing commit $commit ->{hash} (" . (++ $commitcount ) . " of $committotal )" );
2153 if ( defined $lastpicked )
2155 if (! in_array
( $lastpicked , @
{ $commit ->{ parents
}}))
2157 # skip, we'll see this delta
2158 # as part of a merge later
2159 # warn "skipping off-track $commit->{hash}\n";
2161 } elsif ( @
{ $commit ->{ parents
}} > 1 ) {
2162 # it is a merge commit, for each parent that is
2163 # not $lastpicked, see if we can get a log
2164 # from the merge-base to that parent to put it
2165 # in the message as a merge summary.
2166 my @parents = @
{ $commit ->{ parents
}};
2167 foreach my $parent ( @parents ) {
2168 # git-merge-base can potentially (but rarely) throw
2169 # several candidate merge bases. let's assume
2170 # that the first one is the best one.
2171 if ( $parent eq $lastpicked ) {
2174 open my $p , 'git-merge-base ' . $lastpicked . ' '
2176 my @output = (< $p >);
2178 my $base = join ( '' , @output );
2182 # print "want to log between $base $parent \n";
2183 open ( GITLOG
, '-|' , 'git-log' , " $base .. $parent " )
2184 or die "Cannot call git-log: $!" ;
2188 if (! defined $mergedhash ) {
2189 if ( m/^commit\s+(.+)$/ ) {
2195 # grab the first line that looks non-rfc822
2196 # aka has content after leading space
2197 if ( m/^\s+(\S.*)$/ ) {
2199 $title = substr ( $title , 0 , 100 ); # truncate
2200 unshift @merged , " $mergedhash $title " ;
2207 $commit ->{ mergemsg
} = $commit ->{ message
};
2208 $commit ->{ mergemsg
} .= " \n Summary of merged commits: \n\n " ;
2209 foreach my $summary ( @merged ) {
2210 $commit ->{ mergemsg
} .= " \t $summary \n " ;
2212 $commit ->{ mergemsg
} .= " \n\n " ;
2213 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
2220 # convert the date to CVS-happy format
2221 $commit ->{ date
} = " $2 $1 $4 $3 $5 " if ( $commit ->{ date
} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
2223 if ( defined ( $lastpicked ) )
2225 my $filepipe = open ( FILELIST
, '-|' , 'git-diff-tree' , '-r' , $lastpicked , $commit ->{ hash
}) or die ( "Cannot call git-diff-tree : $!" );
2226 while ( < FILELIST
> )
2228 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 )
2230 die ( "Couldn't process git-diff-tree line : $_ " );
2233 # $log->debug("File mode=$1, hash=$2, change=$3, name=$4");
2236 $git_perms .= "r" if ( $1 & 4 );
2237 $git_perms .= "w" if ( $1 & 2 );
2238 $git_perms .= "x" if ( $1 & 1 );
2239 $git_perms = "rw" if ( $git_perms eq "" );
2243 #$log->debug("DELETE $4");
2246 revision
=> $head ->{ $4 }{ revision
} + 1 ,
2247 filehash
=> "deleted" ,
2248 commithash
=> $commit ->{ hash
},
2249 modified
=> $commit ->{ date
},
2250 author
=> $commit ->{ author
},
2253 $db_insert_rev -> execute ( $4 , $head ->{ $4 }{ revision
}, $2 , $commit ->{ hash
}, $commit ->{ date
}, $commit ->{ author
}, $git_perms );
2257 #$log->debug("MODIFIED $4");
2260 revision
=> $head ->{ $4 }{ revision
} + 1 ,
2262 commithash
=> $commit ->{ hash
},
2263 modified
=> $commit ->{ date
},
2264 author
=> $commit ->{ author
},
2267 $db_insert_rev -> execute ( $4 , $head ->{ $4 }{ revision
}, $2 , $commit ->{ hash
}, $commit ->{ date
}, $commit ->{ author
}, $git_perms );
2271 #$log->debug("ADDED $4");
2276 commithash
=> $commit ->{ hash
},
2277 modified
=> $commit ->{ date
},
2278 author
=> $commit ->{ author
},
2281 $db_insert_rev -> execute ( $4 , $head ->{ $4 }{ revision
}, $2 , $commit ->{ hash
}, $commit ->{ date
}, $commit ->{ author
}, $git_perms );
2285 $log -> warn ( "UNKNOWN FILE CHANGE mode= $1 , hash= $2 , change= $3 , name= $4 " );
2291 # this is used to detect files removed from the repo
2292 my $seen_files = {};
2294 my $filepipe = open ( FILELIST
, '-|' , 'git-ls-tree' , '-r' , $commit ->{ hash
}) or die ( "Cannot call git-ls-tree : $!" );
2295 while ( < FILELIST
> )
2297 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\s+(.*)$/o )
2299 die ( "Couldn't process git-ls-tree line : $_ " );
2302 my ( $git_perms , $git_type , $git_hash , $git_filename ) = ( $1 , $2 , $3 , $4 );
2304 $seen_files ->{ $git_filename } = 1 ;
2306 my ( $oldhash , $oldrevision , $oldmode ) = (
2307 $head ->{ $git_filename }{ filehash
},
2308 $head ->{ $git_filename }{ revision
},
2309 $head ->{ $git_filename }{ mode
}
2312 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
2315 $git_perms .= "r" if ( $1 & 4 );
2316 $git_perms .= "w" if ( $1 & 2 );
2317 $git_perms .= "x" if ( $1 & 1 );
2322 # unless the file exists with the same hash, we need to update it ...
2323 unless ( defined ( $oldhash ) and $oldhash eq $git_hash and defined ( $oldmode ) and $oldmode eq $git_perms )
2325 my $newrevision = ( $oldrevision or 0 ) + 1 ;
2327 $head ->{ $git_filename } = {
2328 name
=> $git_filename ,
2329 revision
=> $newrevision ,
2330 filehash
=> $git_hash ,
2331 commithash
=> $commit ->{ hash
},
2332 modified
=> $commit ->{ date
},
2333 author
=> $commit ->{ author
},
2338 $db_insert_rev -> execute ( $git_filename , $newrevision , $git_hash , $commit ->{ hash
}, $commit ->{ date
}, $commit ->{ author
}, $git_perms );
2343 # Detect deleted files
2344 foreach my $file ( keys % $head )
2346 unless ( exists $seen_files ->{ $file } or $head ->{ $file }{ filehash
} eq "deleted" )
2348 $head ->{ $file }{ revision
}++;
2349 $head ->{ $file }{ filehash
} = "deleted" ;
2350 $head ->{ $file }{ commithash
} = $commit ->{ hash
};
2351 $head ->{ $file }{ modified
} = $commit ->{ date
};
2352 $head ->{ $file }{ author
} = $commit ->{ author
};
2354 $db_insert_rev -> execute ( $file , $head ->{ $file }{ revision
}, $head ->{ $file }{ filehash
}, $commit ->{ hash
}, $commit ->{ date
}, $commit ->{ author
}, $head ->{ $file }{ mode
});
2357 # END : "Detect deleted files"
2361 if ( exists $commit ->{ mergemsg
})
2363 $db_insert_mergelog -> execute ( $commit ->{ hash
}, $commit ->{ mergemsg
});
2366 $lastpicked = $commit ->{ hash
};
2368 $self -> _set_prop ( "last_commit" , $commit ->{ hash
});
2371 $db_delete_head -> execute ();
2372 foreach my $file ( keys % $head )
2374 $db_insert_head -> execute (
2376 $head ->{ $file }{ revision
},
2377 $head ->{ $file }{ filehash
},
2378 $head ->{ $file }{ commithash
},
2379 $head ->{ $file }{ modified
},
2380 $head ->{ $file }{ author
},
2381 $head ->{ $file }{ mode
},
2384 # invalidate the gethead cache
2385 $self ->{ gethead_cache
} = undef ;
2388 # Ending exclusive lock here
2389 $self ->{ dbh
}-> commit () or die "Failed to commit changes to SQLite" ;
2395 my $filename = shift ;
2397 my $db_query = $self ->{ dbh
}-> prepare_cached ( "SELECT filehash, revision, mode FROM head WHERE name=?" ,{}, 1 );
2398 $db_query -> execute ( $filename );
2399 my ( $hash , $revision , $mode ) = $db_query -> fetchrow_array ;
2401 return ( $hash , $revision , $mode );
2409 my $db_query = $self ->{ dbh
}-> prepare_cached ( "SELECT value FROM properties WHERE key=?" ,{}, 1 );
2410 $db_query -> execute ( $key );
2411 my ( $value ) = $db_query -> fetchrow_array ;
2422 my $db_query = $self ->{ dbh
}-> prepare_cached ( "UPDATE properties SET value=? WHERE key=?" ,{}, 1 );
2423 $db_query -> execute ( $value , $key );
2425 unless ( $db_query -> rows )
2427 $db_query = $self ->{ dbh
}-> prepare_cached ( "INSERT INTO properties (key, value) VALUES (?,?)" ,{}, 1 );
2428 $db_query -> execute ( $key , $value );
2442 return $self ->{ gethead_cache
} if ( defined ( $self ->{ gethead_cache
} ) );
2444 my $db_query = $self ->{ dbh
}-> prepare_cached ( "SELECT name, filehash, mode, revision, modified, commithash, author FROM head ORDER BY name ASC" ,{}, 1 );
2445 $db_query -> execute ();
2448 while ( my $file = $db_query -> fetchrow_hashref )
2453 $self ->{ gethead_cache
} = $tree ;
2465 my $filename = shift ;
2467 my $db_query = $self ->{ dbh
}-> prepare_cached ( "SELECT name, filehash, author, mode, revision, modified, commithash FROM revision WHERE name=? ORDER BY revision DESC" ,{}, 1 );
2468 $db_query -> execute ( $filename );
2471 while ( my $file = $db_query -> fetchrow_hashref )
2481 This function takes a filename (with path) argument and returns a hashref of
2482 metadata for that file.
2489 my $filename = shift ;
2490 my $revision = shift ;
2493 if ( defined ( $revision ) and $revision =~ /^\d+$/ )
2495 $db_query = $self ->{ dbh
}-> prepare_cached ( "SELECT * FROM revision WHERE name=? AND revision=?" ,{}, 1 );
2496 $db_query -> execute ( $filename , $revision );
2498 elsif ( defined ( $revision ) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
2500 $db_query = $self ->{ dbh
}-> prepare_cached ( "SELECT * FROM revision WHERE name=? AND commithash=?" ,{}, 1 );
2501 $db_query -> execute ( $filename , $revision );
2503 $db_query = $self ->{ dbh
}-> prepare_cached ( "SELECT * FROM head WHERE name=?" ,{}, 1 );
2504 $db_query -> execute ( $filename );
2507 return $db_query -> fetchrow_hashref ;
2510 =head2 commitmessage
2512 this function takes a commithash and returns the commit message for that commit
2518 my $commithash = shift ;
2520 die ( "Need commithash" ) unless ( defined ( $commithash ) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
2523 $db_query = $self ->{ dbh
}-> prepare_cached ( "SELECT value FROM commitmsgs WHERE key=?" ,{}, 1 );
2524 $db_query -> execute ( $commithash );
2526 my ( $message ) = $db_query -> fetchrow_array ;
2528 if ( defined ( $message ) )
2530 $message .= " " if ( $message =~ /\n$/ );
2534 my @lines = safe_pipe_capture
( "git-cat-file" , "commit" , $commithash );
2535 shift @lines while ( $lines [ 0 ] =~ /\S/ );
2536 $message = join ( "" , @lines );
2537 $message .= " " if ( $message =~ /\n$/ );
2543 This function takes a filename (with path) argument and returns an arrayofarrays
2544 containing revision,filehash,commithash ordered by revision descending
2550 my $filename = shift ;
2553 $db_query = $self ->{ dbh
}-> prepare_cached ( "SELECT revision, filehash, commithash FROM revision WHERE name=? ORDER BY revision DESC" ,{}, 1 );
2554 $db_query -> execute ( $filename );
2556 return $db_query -> fetchall_arrayref ;
2559 =head2 gethistorydense
2561 This function takes a filename (with path) argument and returns an arrayofarrays
2562 containing revision,filehash,commithash ordered by revision descending.
2564 This version of gethistory skips deleted entries -- so it is useful for annotate.
2565 The 'dense' part is a reference to a '--dense' option available for git-rev-list
2566 and other git tools that depend on it.
2572 my $filename = shift ;
2575 $db_query = $self ->{ dbh
}-> prepare_cached ( "SELECT revision, filehash, commithash FROM revision WHERE name=? AND filehash!='deleted' ORDER BY revision DESC" ,{}, 1 );
2576 $db_query -> execute ( $filename );
2578 return $db_query -> fetchall_arrayref ;
2583 from Array::PAT - mimics the in_array() function
2584 found in PHP. Yuck but works for small arrays.
2589 my ( $check , @array ) = @_ ;
2591 foreach my $test ( @array ){
2592 if ( $check eq $test ){
2599 =head2 safe_pipe_capture
2601 an alternative to `command` that allows input to be passed as an array
2602 to work around shell problems with weird characters in arguments
2605 sub safe_pipe_capture
{
2609 if ( my $pid = open my $child , '-|' ) {
2610 @output = (< $child >);
2611 close $child or die join ( ' ' , @_ ). ": $! $?" ;
2613 exec ( @_ ) or die "$! $?" ; # exec() can fail the executable can't be found
2615 return wantarray ?
@output : join ( '' , @output );