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