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