1 #!/usr/bin/perl
3 ####
4 #### This application is a CVS emulation layer for git.
5 #### It is intended for clients to connect over SSH.
6 #### See the documentation for more details.
7 ####
8 #### Copyright The Open University UK - 2006.
9 ####
10 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
11 #### Martin Langhoff <martin@catalyst.net.nz>
12 ####
13 ####
14 #### Released under the GNU Public License, version 2.
15 ####
16 ####
18 use strict;
19 use warnings;
20 use bytes;
22 use Fcntl;
23 use File::Temp qw/tempdir tempfile/;
24 use File::Basename;
26 my $log = GITCVS::log->new();
27 my $cfg;
29 my $DATE_LIST = {
30 Jan => "01",
31 Feb => "02",
32 Mar => "03",
33 Apr => "04",
34 May => "05",
35 Jun => "06",
36 Jul => "07",
37 Aug => "08",
38 Sep => "09",
39 Oct => "10",
40 Nov => "11",
41 Dec => "12",
42 };
44 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
45 $| = 1;
47 #### Definition and mappings of functions ####
49 my $methods = {
50 'Root' => \&req_Root,
51 'Valid-responses' => \&req_Validresponses,
52 'valid-requests' => \&req_validrequests,
53 'Directory' => \&req_Directory,
54 'Entry' => \&req_Entry,
55 'Modified' => \&req_Modified,
56 'Unchanged' => \&req_Unchanged,
57 'Questionable' => \&req_Questionable,
58 'Argument' => \&req_Argument,
59 'Argumentx' => \&req_Argument,
60 'expand-modules' => \&req_expandmodules,
61 'add' => \&req_add,
62 'remove' => \&req_remove,
63 'co' => \&req_co,
64 'update' => \&req_update,
65 'ci' => \&req_ci,
66 'diff' => \&req_diff,
67 'log' => \&req_log,
68 'rlog' => \&req_log,
69 'tag' => \&req_CATCHALL,
70 'status' => \&req_status,
71 'admin' => \&req_CATCHALL,
72 'history' => \&req_CATCHALL,
73 'watchers' => \&req_CATCHALL,
74 'editors' => \&req_CATCHALL,
75 'annotate' => \&req_annotate,
76 'Global_option' => \&req_Globaloption,
77 #'annotate' => \&req_CATCHALL,
78 };
80 ##############################################
83 # $state holds all the bits of information the clients sends us that could
84 # potentially be useful when it comes to actually _doing_ something.
85 my $state = { prependdir => '' };
86 $log->info("--------------- STARTING -----------------");
88 my $TEMP_DIR = tempdir( CLEANUP => 1 );
89 $log->debug("Temporary directory is '$TEMP_DIR'");
91 # if we are called with a pserver argument,
92 # deal with the authentication cat before entering the
93 # main loop
94 if (@ARGV && $ARGV[0] eq 'pserver') {
95 my $line = <STDIN>; chomp $line;
96 unless( $line eq 'BEGIN AUTH REQUEST') {
97 die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n";
98 }
99 $line = <STDIN>; chomp $line;
100 req_Root('root', $line) # reuse Root
101 or die "E Invalid root $line \n";
102 $line = <STDIN>; chomp $line;
103 unless ($line eq 'anonymous') {
104 print "E Only anonymous user allowed via pserver\n";
105 print "I HATE YOU\n";
106 }
107 $line = <STDIN>; chomp $line; # validate the password?
108 $line = <STDIN>; chomp $line;
109 unless ($line eq 'END AUTH REQUEST') {
110 die "E Do not understand $line -- expecting END AUTH REQUEST\n";
111 }
112 print "I LOVE YOU\n";
113 # and now back to our regular programme...
114 }
116 # Keep going until the client closes the connection
117 while (<STDIN>)
118 {
119 chomp;
121 # Check to see if we've seen this method, and call appropriate function.
122 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
123 {
124 # use the $methods hash to call the appropriate sub for this command
125 #$log->info("Method : $1");
126 &{$methods->{$1}}($1,$2);
127 } else {
128 # log fatal because we don't understand this function. If this happens
129 # we're fairly screwed because we don't know if the client is expecting
130 # a response. If it is, the client will hang, we'll hang, and the whole
131 # thing will be custard.
132 $log->fatal("Don't understand command $_\n");
133 die("Unknown command $_");
134 }
135 }
137 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
138 $log->info("--------------- FINISH -----------------");
140 # Magic catchall method.
141 # This is the method that will handle all commands we haven't yet
142 # implemented. It simply sends a warning to the log file indicating a
143 # command that hasn't been implemented has been invoked.
144 sub req_CATCHALL
145 {
146 my ( $cmd, $data ) = @_;
147 $log->warn("Unhandled command : req_$cmd : $data");
148 }
151 # Root pathname \n
152 # Response expected: no. Tell the server which CVSROOT to use. Note that
153 # pathname is a local directory and not a fully qualified CVSROOT variable.
154 # pathname must already exist; if creating a new root, use the init
155 # request, not Root. pathname does not include the hostname of the server,
156 # how to access the server, etc.; by the time the CVS protocol is in use,
157 # connection, authentication, etc., are already taken care of. The Root
158 # request must be sent only once, and it must be sent before any requests
159 # other than Valid-responses, valid-requests, UseUnchanged, Set or init.
160 sub req_Root
161 {
162 my ( $cmd, $data ) = @_;
163 $log->debug("req_Root : $data");
165 $state->{CVSROOT} = $data;
167 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
168 unless (-d $ENV{GIT_DIR} && -e $ENV{GIT_DIR}.'HEAD') {
169 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
170 print "E \n";
171 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
172 return 0;
173 }
175 my @gitvars = `git-config -l`;
176 if ($?) {
177 print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
178 print "E \n";
179 print "error 1 - problem executing git-config\n";
180 return 0;
181 }
182 foreach my $line ( @gitvars )
183 {
184 next unless ( $line =~ /^(.*?)\.(.*?)=(.*)$/ );
185 $cfg->{$1}{$2} = $3;
186 }
188 unless ( defined ( $cfg->{gitcvs}{enabled} ) and $cfg->{gitcvs}{enabled} =~ /^\s*(1|true|yes)\s*$/i )
189 {
190 print "E GITCVS emulation needs to be enabled on this repo\n";
191 print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
192 print "E \n";
193 print "error 1 GITCVS emulation disabled\n";
194 return 0;
195 }
197 if ( defined ( $cfg->{gitcvs}{logfile} ) )
198 {
199 $log->setfile($cfg->{gitcvs}{logfile});
200 } else {
201 $log->nofile();
202 }
204 return 1;
205 }
207 # Global_option option \n
208 # Response expected: no. Transmit one of the global options `-q', `-Q',
209 # `-l', `-t', `-r', or `-n'. option must be one of those strings, no
210 # variations (such as combining of options) are allowed. For graceful
211 # handling of valid-requests, it is probably better to make new global
212 # options separate requests, rather than trying to add them to this
213 # request.
214 sub req_Globaloption
215 {
216 my ( $cmd, $data ) = @_;
217 $log->debug("req_Globaloption : $data");
218 $state->{globaloptions}{$data} = 1;
219 }
221 # Valid-responses request-list \n
222 # Response expected: no. Tell the server what responses the client will
223 # accept. request-list is a space separated list of tokens.
224 sub req_Validresponses
225 {
226 my ( $cmd, $data ) = @_;
227 $log->debug("req_Validresponses : $data");
229 # TODO : re-enable this, currently it's not particularly useful
230 #$state->{validresponses} = [ split /\s+/, $data ];
231 }
233 # valid-requests \n
234 # Response expected: yes. Ask the server to send back a Valid-requests
235 # response.
236 sub req_validrequests
237 {
238 my ( $cmd, $data ) = @_;
240 $log->debug("req_validrequests");
242 $log->debug("SEND : Valid-requests " . join(" ",keys %$methods));
243 $log->debug("SEND : ok");
245 print "Valid-requests " . join(" ",keys %$methods) . "\n";
246 print "ok\n";
247 }
249 # Directory local-directory \n
250 # Additional data: repository \n. Response expected: no. Tell the server
251 # what directory to use. The repository should be a directory name from a
252 # previous server response. Note that this both gives a default for Entry
253 # and Modified and also for ci and the other commands; normal usage is to
254 # send Directory for each directory in which there will be an Entry or
255 # Modified, and then a final Directory for the original directory, then the
256 # command. The local-directory is relative to the top level at which the
257 # command is occurring (i.e. the last Directory which is sent before the
258 # command); to indicate that top level, `.' should be sent for
259 # local-directory.
260 sub req_Directory
261 {
262 my ( $cmd, $data ) = @_;
264 my $repository = <STDIN>;
265 chomp $repository;
268 $state->{localdir} = $data;
269 $state->{repository} = $repository;
270 $state->{path} = $repository;
271 $state->{path} =~ s/^$state->{CVSROOT}\///;
272 $state->{module} = $1 if ($state->{path} =~ s/^(.*?)(\/|$)//);
273 $state->{path} .= "/" if ( $state->{path} =~ /\S/ );
275 $state->{directory} = $state->{localdir};
276 $state->{directory} = "" if ( $state->{directory} eq "." );
277 $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
279 if ( (not defined($state->{prependdir}) or $state->{prependdir} eq '') and $state->{localdir} eq "." and $state->{path} =~ /\S/ )
280 {
281 $log->info("Setting prepend to '$state->{path}'");
282 $state->{prependdir} = $state->{path};
283 foreach my $entry ( keys %{$state->{entries}} )
284 {
285 $state->{entries}{$state->{prependdir} . $entry} = $state->{entries}{$entry};
286 delete $state->{entries}{$entry};
287 }
288 }
290 if ( defined ( $state->{prependdir} ) )
291 {
292 $log->debug("Prepending '$state->{prependdir}' to state|directory");
293 $state->{directory} = $state->{prependdir} . $state->{directory}
294 }
295 $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
296 }
298 # Entry entry-line \n
299 # Response expected: no. Tell the server what version of a file is on the
300 # local machine. The name in entry-line is a name relative to the directory
301 # most recently specified with Directory. If the user is operating on only
302 # some files in a directory, Entry requests for only those files need be
303 # included. If an Entry request is sent without Modified, Is-modified, or
304 # Unchanged, it means the file is lost (does not exist in the working
305 # directory). If both Entry and one of Modified, Is-modified, or Unchanged
306 # are sent for the same file, Entry must be sent first. For a given file,
307 # one can send Modified, Is-modified, or Unchanged, but not more than one
308 # of these three.
309 sub req_Entry
310 {
311 my ( $cmd, $data ) = @_;
313 #$log->debug("req_Entry : $data");
315 my @data = split(/\//, $data);
317 $state->{entries}{$state->{directory}.$data[1]} = {
318 revision => $data[2],
319 conflict => $data[3],
320 options => $data[4],
321 tag_or_date => $data[5],
322 };
324 $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'");
325 }
327 # Questionable filename \n
328 # Response expected: no. Additional data: no. Tell the server to check
329 # whether filename should be ignored, and if not, next time the server
330 # sends responses, send (in a M response) `?' followed by the directory and
331 # filename. filename must not contain `/'; it needs to be a file in the
332 # directory named by the most recent Directory request.
333 sub req_Questionable
334 {
335 my ( $cmd, $data ) = @_;
337 $log->debug("req_Questionable : $data");
338 $state->{entries}{$state->{directory}.$data}{questionable} = 1;
339 }
341 # add \n
342 # Response expected: yes. Add a file or directory. This uses any previous
343 # Argument, Directory, Entry, or Modified requests, if they have been sent.
344 # The last Directory sent specifies the working directory at the time of
345 # the operation. To add a directory, send the directory to be added using
346 # Directory and Argument requests.
347 sub req_add
348 {
349 my ( $cmd, $data ) = @_;
351 argsplit("add");
353 my $addcount = 0;
355 foreach my $filename ( @{$state->{args}} )
356 {
357 $filename = filecleanup($filename);
359 unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
360 {
361 print "E cvs add: nothing known about `$filename'\n";
362 next;
363 }
364 # TODO : check we're not squashing an already existing file
365 if ( defined ( $state->{entries}{$filename}{revision} ) )
366 {
367 print "E cvs add: `$filename' has already been entered\n";
368 next;
369 }
371 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
373 print "E cvs add: scheduling file `$filename' for addition\n";
375 print "Checked-in $dirpart\n";
376 print "$filename\n";
377 my $kopts = kopts_from_path($filepart);
378 print "/$filepart/0//$kopts/\n";
380 $addcount++;
381 }
383 if ( $addcount == 1 )
384 {
385 print "E cvs add: use `cvs commit' to add this file permanently\n";
386 }
387 elsif ( $addcount > 1 )
388 {
389 print "E cvs add: use `cvs commit' to add these files permanently\n";
390 }
392 print "ok\n";
393 }
395 # remove \n
396 # Response expected: yes. Remove a file. This uses any previous Argument,
397 # Directory, Entry, or Modified requests, if they have been sent. The last
398 # Directory sent specifies the working directory at the time of the
399 # operation. Note that this request does not actually do anything to the
400 # repository; the only effect of a successful remove request is to supply
401 # the client with a new entries line containing `-' to indicate a removed
402 # file. In fact, the client probably could perform this operation without
403 # contacting the server, although using remove may cause the server to
404 # perform a few more checks. The client sends a subsequent ci request to
405 # actually record the removal in the repository.
406 sub req_remove
407 {
408 my ( $cmd, $data ) = @_;
410 argsplit("remove");
412 # Grab a handle to the SQLite db and do any necessary updates
413 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
414 $updater->update();
416 #$log->debug("add state : " . Dumper($state));
418 my $rmcount = 0;
420 foreach my $filename ( @{$state->{args}} )
421 {
422 $filename = filecleanup($filename);
424 if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
425 {
426 print "E cvs remove: file `$filename' still in working directory\n";
427 next;
428 }
430 my $meta = $updater->getmeta($filename);
431 my $wrev = revparse($filename);
433 unless ( defined ( $wrev ) )
434 {
435 print "E cvs remove: nothing known about `$filename'\n";
436 next;
437 }
439 if ( defined($wrev) and $wrev < 0 )
440 {
441 print "E cvs remove: file `$filename' already scheduled for removal\n";
442 next;
443 }
445 unless ( $wrev == $meta->{revision} )
446 {
447 # TODO : not sure if the format of this message is quite correct.
448 print "E cvs remove: Up to date check failed for `$filename'\n";
449 next;
450 }
453 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
455 print "E cvs remove: scheduling `$filename' for removal\n";
457 print "Checked-in $dirpart\n";
458 print "$filename\n";
459 my $kopts = kopts_from_path($filepart);
460 print "/$filepart/-1.$wrev//$kopts/\n";
462 $rmcount++;
463 }
465 if ( $rmcount == 1 )
466 {
467 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
468 }
469 elsif ( $rmcount > 1 )
470 {
471 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
472 }
474 print "ok\n";
475 }
477 # Modified filename \n
478 # Response expected: no. Additional data: mode, \n, file transmission. Send
479 # the server a copy of one locally modified file. filename is a file within
480 # the most recent directory sent with Directory; it must not contain `/'.
481 # If the user is operating on only some files in a directory, only those
482 # files need to be included. This can also be sent without Entry, if there
483 # is no entry for the file.
484 sub req_Modified
485 {
486 my ( $cmd, $data ) = @_;
488 my $mode = <STDIN>;
489 chomp $mode;
490 my $size = <STDIN>;
491 chomp $size;
493 # Grab config information
494 my $blocksize = 8192;
495 my $bytesleft = $size;
496 my $tmp;
498 # Get a filehandle/name to write it to
499 my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
501 # Loop over file data writing out to temporary file.
502 while ( $bytesleft )
503 {
504 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
505 read STDIN, $tmp, $blocksize;
506 print $fh $tmp;
507 $bytesleft -= $blocksize;
508 }
510 close $fh;
512 # Ensure we have something sensible for the file mode
513 if ( $mode =~ /u=(\w+)/ )
514 {
515 $mode = $1;
516 } else {
517 $mode = "rw";
518 }
520 # Save the file data in $state
521 $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
522 $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
523 $state->{entries}{$state->{directory}.$data}{modified_hash} = `git-hash-object $filename`;
524 $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
526 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
527 }
529 # Unchanged filename \n
530 # Response expected: no. Tell the server that filename has not been
531 # modified in the checked out directory. The filename is a file within the
532 # most recent directory sent with Directory; it must not contain `/'.
533 sub req_Unchanged
534 {
535 my ( $cmd, $data ) = @_;
537 $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
539 #$log->debug("req_Unchanged : $data");
540 }
542 # Argument text \n
543 # Response expected: no. Save argument for use in a subsequent command.
544 # Arguments accumulate until an argument-using command is given, at which
545 # point they are forgotten.
546 # Argumentx text \n
547 # Response expected: no. Append \n followed by text to the current argument
548 # being saved.
549 sub req_Argument
550 {
551 my ( $cmd, $data ) = @_;
553 # Argumentx means: append to last Argument (with a newline in front)
555 $log->debug("$cmd : $data");
557 if ( $cmd eq 'Argumentx') {
558 ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
559 } else {
560 push @{$state->{arguments}}, $data;
561 }
562 }
564 # expand-modules \n
565 # Response expected: yes. Expand the modules which are specified in the
566 # arguments. Returns the data in Module-expansion responses. Note that the
567 # server can assume that this is checkout or export, not rtag or rdiff; the
568 # latter do not access the working directory and thus have no need to
569 # expand modules on the client side. Expand may not be the best word for
570 # what this request does. It does not necessarily tell you all the files
571 # contained in a module, for example. Basically it is a way of telling you
572 # which working directories the server needs to know about in order to
573 # handle a checkout of the specified modules. For example, suppose that the
574 # server has a module defined by
575 # aliasmodule -a 1dir
576 # That is, one can check out aliasmodule and it will take 1dir in the
577 # repository and check it out to 1dir in the working directory. Now suppose
578 # the client already has this module checked out and is planning on using
579 # the co request to update it. Without using expand-modules, the client
580 # would have two bad choices: it could either send information about all
581 # working directories under the current directory, which could be
582 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
583 # stands for 1dir, and neglect to send information for 1dir, which would
584 # lead to incorrect operation. With expand-modules, the client would first
585 # ask for the module to be expanded:
586 sub req_expandmodules
587 {
588 my ( $cmd, $data ) = @_;
590 argsplit();
592 $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
594 unless ( ref $state->{arguments} eq "ARRAY" )
595 {
596 print "ok\n";
597 return;
598 }
600 foreach my $module ( @{$state->{arguments}} )
601 {
602 $log->debug("SEND : Module-expansion $module");
603 print "Module-expansion $module\n";
604 }
606 print "ok\n";
607 statecleanup();
608 }
610 # co \n
611 # Response expected: yes. Get files from the repository. This uses any
612 # previous Argument, Directory, Entry, or Modified requests, if they have
613 # been sent. Arguments to this command are module names; the client cannot
614 # know what directories they correspond to except by (1) just sending the
615 # co request, and then seeing what directory names the server sends back in
616 # its responses, and (2) the expand-modules request.
617 sub req_co
618 {
619 my ( $cmd, $data ) = @_;
621 argsplit("co");
623 my $module = $state->{args}[0];
624 my $checkout_path = $module;
626 # use the user specified directory if we're given it
627 $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
629 $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
631 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
633 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
635 # Grab a handle to the SQLite db and do any necessary updates
636 my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
637 $updater->update();
639 $checkout_path =~ s|/$||; # get rid of trailing slashes
641 # Eclipse seems to need the Clear-sticky command
642 # to prepare the 'Entries' file for the new directory.
643 print "Clear-sticky $checkout_path/\n";
644 print $state->{CVSROOT} . "/$module/\n";
645 print "Clear-static-directory $checkout_path/\n";
646 print $state->{CVSROOT} . "/$module/\n";
647 print "Clear-sticky $checkout_path/\n"; # yes, twice
648 print $state->{CVSROOT} . "/$module/\n";
649 print "Template $checkout_path/\n";
650 print $state->{CVSROOT} . "/$module/\n";
651 print "0\n";
653 # instruct the client that we're checking out to $checkout_path
654 print "E cvs checkout: Updating $checkout_path\n";
656 my %seendirs = ();
657 my $lastdir ='';
659 # recursive
660 sub prepdir {
661 my ($dir, $repodir, $remotedir, $seendirs) = @_;
662 my $parent = dirname($dir);
663 $dir =~ s|/+$||;
664 $repodir =~ s|/+$||;
665 $remotedir =~ s|/+$||;
666 $parent =~ s|/+$||;
667 $log->debug("announcedir $dir, $repodir, $remotedir" );
669 if ($parent eq '.' || $parent eq './') {
670 $parent = '';
671 }
672 # recurse to announce unseen parents first
673 if (length($parent) && !exists($seendirs->{$parent})) {
674 prepdir($parent, $repodir, $remotedir, $seendirs);
675 }
676 # Announce that we are going to modify at the parent level
677 if ($parent) {
678 print "E cvs checkout: Updating $remotedir/$parent\n";
679 } else {
680 print "E cvs checkout: Updating $remotedir\n";
681 }
682 print "Clear-sticky $remotedir/$parent/\n";
683 print "$repodir/$parent/\n";
685 print "Clear-static-directory $remotedir/$dir/\n";
686 print "$repodir/$dir/\n";
687 print "Clear-sticky $remotedir/$parent/\n"; # yes, twice
688 print "$repodir/$parent/\n";
689 print "Template $remotedir/$dir/\n";
690 print "$repodir/$dir/\n";
691 print "0\n";
693 $seendirs->{$dir} = 1;
694 }
696 foreach my $git ( @{$updater->gethead} )
697 {
698 # Don't want to check out deleted files
699 next if ( $git->{filehash} eq "deleted" );
701 ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
703 if (length($git->{dir}) && $git->{dir} ne './'
704 && $git->{dir} ne $lastdir ) {
705 unless (exists($seendirs{$git->{dir}})) {
706 prepdir($git->{dir}, $state->{CVSROOT} . "/$module/",
707 $checkout_path, \%seendirs);
708 $lastdir = $git->{dir};
709 $seendirs{$git->{dir}} = 1;
710 }
711 print "E cvs checkout: Updating /$checkout_path/$git->{dir}\n";
712 }
714 # modification time of this file
715 print "Mod-time $git->{modified}\n";
717 # print some information to the client
718 if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
719 {
720 print "M U $checkout_path/$git->{dir}$git->{name}\n";
721 } else {
722 print "M U $checkout_path/$git->{name}\n";
723 }
725 # instruct client we're sending a file to put in this path
726 print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
728 print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
730 # this is an "entries" line
731 my $kopts = kopts_from_path($git->{name});
732 print "/$git->{name}/1.$git->{revision}//$kopts/\n";
733 # permissions
734 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
736 # transmit file
737 transmitfile($git->{filehash});
738 }
740 print "ok\n";
742 statecleanup();
743 }
745 # update \n
746 # Response expected: yes. Actually do a cvs update command. This uses any
747 # previous Argument, Directory, Entry, or Modified requests, if they have
748 # been sent. The last Directory sent specifies the working directory at the
749 # time of the operation. The -I option is not used--files which the client
750 # can decide whether to ignore are not mentioned and the client sends the
751 # Questionable request for others.
752 sub req_update
753 {
754 my ( $cmd, $data ) = @_;
756 $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
758 argsplit("update");
760 #
761 # It may just be a client exploring the available heads/modules
762 # in that case, list them as top level directories and leave it
763 # at that. Eclipse uses this technique to offer you a list of
764 # projects (heads in this case) to checkout.
765 #
766 if ($state->{module} eq '') {
767 print "E cvs update: Updating .\n";
768 opendir HEADS, $state->{CVSROOT} . '/refs/heads';
769 while (my $head = readdir(HEADS)) {
770 if (-f $state->{CVSROOT} . '/refs/heads/' . $head) {
771 print "E cvs update: New directory `$head'\n";
772 }
773 }
774 closedir HEADS;
775 print "ok\n";
776 return 1;
777 }
780 # Grab a handle to the SQLite db and do any necessary updates
781 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
783 $updater->update();
785 argsfromdir($updater);
787 #$log->debug("update state : " . Dumper($state));
789 # foreach file specified on the command line ...
790 foreach my $filename ( @{$state->{args}} )
791 {
792 $filename = filecleanup($filename);
794 $log->debug("Processing file $filename");
796 # if we have a -C we should pretend we never saw modified stuff
797 if ( exists ( $state->{opt}{C} ) )
798 {
799 delete $state->{entries}{$filename}{modified_hash};
800 delete $state->{entries}{$filename}{modified_filename};
801 $state->{entries}{$filename}{unchanged} = 1;
802 }
804 my $meta;
805 if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^1\.(\d+)/ )
806 {
807 $meta = $updater->getmeta($filename, $1);
808 } else {
809 $meta = $updater->getmeta($filename);
810 }
812 if ( ! defined $meta )
813 {
814 $meta = {
815 name => $filename,
816 revision => 0,
817 filehash => 'added'
818 };
819 }
821 my $oldmeta = $meta;
823 my $wrev = revparse($filename);
825 # If the working copy is an old revision, lets get that version too for comparison.
826 if ( defined($wrev) and $wrev != $meta->{revision} )
827 {
828 $oldmeta = $updater->getmeta($filename, $wrev);
829 }
831 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
833 # Files are up to date if the working copy and repo copy have the same revision,
834 # and the working copy is unmodified _and_ the user hasn't specified -C
835 next if ( defined ( $wrev )
836 and defined($meta->{revision})
837 and $wrev == $meta->{revision}
838 and $state->{entries}{$filename}{unchanged}
839 and not exists ( $state->{opt}{C} ) );
841 # If the working copy and repo copy have the same revision,
842 # but the working copy is modified, tell the client it's modified
843 if ( defined ( $wrev )
844 and defined($meta->{revision})
845 and $wrev == $meta->{revision}
846 and not exists ( $state->{opt}{C} ) )
847 {
848 $log->info("Tell the client the file is modified");
849 print "MT text M \n";
850 print "MT fname $filename\n";
851 print "MT newline\n";
852 next;
853 }
855 if ( $meta->{filehash} eq "deleted" )
856 {
857 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
859 $log->info("Removing '$filename' from working copy (no longer in the repo)");
861 print "E cvs update: `$filename' is no longer in the repository\n";
862 # Don't want to actually _DO_ the update if -n specified
863 unless ( $state->{globaloptions}{-n} ) {
864 print "Removed $dirpart\n";
865 print "$filepart\n";
866 }
867 }
868 elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
869 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
870 or $meta->{filehash} eq 'added' )
871 {
872 # normal update, just send the new revision (either U=Update,
873 # or A=Add, or R=Remove)
874 if ( defined($wrev) && $wrev < 0 )
875 {
876 $log->info("Tell the client the file is scheduled for removal");
877 print "MT text R \n";
878 print "MT fname $filename\n";
879 print "MT newline\n";
880 next;
881 }
882 elsif ( (!defined($wrev) || $wrev == 0) && (!defined($meta->{revision}) || $meta->{revision} == 0) )
883 {
884 $log->info("Tell the client the file is scheduled for addition");
885 print "MT text A \n";
886 print "MT fname $filename\n";
887 print "MT newline\n";
888 next;
890 }
891 else {
892 $log->info("Updating '$filename' to ".$meta->{revision});
893 print "MT +updated\n";
894 print "MT text U \n";
895 print "MT fname $filename\n";
896 print "MT newline\n";
897 print "MT -updated\n";
898 }
900 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
902 # Don't want to actually _DO_ the update if -n specified
903 unless ( $state->{globaloptions}{-n} )
904 {
905 if ( defined ( $wrev ) )
906 {
907 # instruct client we're sending a file to put in this path as a replacement
908 print "Update-existing $dirpart\n";
909 $log->debug("Updating existing file 'Update-existing $dirpart'");
910 } else {
911 # instruct client we're sending a file to put in this path as a new file
912 print "Clear-static-directory $dirpart\n";
913 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
914 print "Clear-sticky $dirpart\n";
915 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
917 $log->debug("Creating new file 'Created $dirpart'");
918 print "Created $dirpart\n";
919 }
920 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
922 # this is an "entries" line
923 my $kopts = kopts_from_path($filepart);
924 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
925 print "/$filepart/1.$meta->{revision}//$kopts/\n";
927 # permissions
928 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
929 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
931 # transmit file
932 transmitfile($meta->{filehash});
933 }
934 } else {
935 $log->info("Updating '$filename'");
936 my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
938 my $dir = tempdir( DIR => $TEMP_DIR, CLEANUP => 1 ) . "/";
940 chdir $dir;
941 my $file_local = $filepart . ".mine";
942 system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
943 my $file_old = $filepart . "." . $oldmeta->{revision};
944 transmitfile($oldmeta->{filehash}, $file_old);
945 my $file_new = $filepart . "." . $meta->{revision};
946 transmitfile($meta->{filehash}, $file_new);
948 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
949 $log->info("Merging $file_local, $file_old, $file_new");
950 print "M Merging differences between 1.$oldmeta->{revision} and 1.$meta->{revision} into $filename\n";
952 $log->debug("Temporary directory for merge is $dir");
954 my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
955 $return >>= 8;
957 if ( $return == 0 )
958 {
959 $log->info("Merged successfully");
960 print "M M $filename\n";
961 $log->debug("Merged $dirpart");
963 # Don't want to actually _DO_ the update if -n specified
964 unless ( $state->{globaloptions}{-n} )
965 {
966 print "Merged $dirpart\n";
967 $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
968 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
969 my $kopts = kopts_from_path($filepart);
970 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
971 print "/$filepart/1.$meta->{revision}//$kopts/\n";
972 }
973 }
974 elsif ( $return == 1 )
975 {
976 $log->info("Merged with conflicts");
977 print "E cvs update: conflicts found in $filename\n";
978 print "M C $filename\n";
980 # Don't want to actually _DO_ the update if -n specified
981 unless ( $state->{globaloptions}{-n} )
982 {
983 print "Merged $dirpart\n";
984 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
985 my $kopts = kopts_from_path($filepart);
986 print "/$filepart/1.$meta->{revision}/+/$kopts/\n";
987 }
988 }
989 else
990 {
991 $log->warn("Merge failed");
992 next;
993 }
995 # Don't want to actually _DO_ the update if -n specified
996 unless ( $state->{globaloptions}{-n} )
997 {
998 # permissions
999 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1000 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1002 # transmit file, format is single integer on a line by itself (file
1003 # size) followed by the file contents
1004 # TODO : we should copy files in blocks
1005 my $data = `cat $file_local`;
1006 $log->debug("File size : " . length($data));
1007 print length($data) . "\n";
1008 print $data;
1009 }
1011 chdir "/";
1012 }
1014 }
1016 print "ok\n";
1017 }
1019 sub req_ci
1020 {
1021 my ( $cmd, $data ) = @_;
1023 argsplit("ci");
1025 #$log->debug("State : " . Dumper($state));
1027 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1029 if ( @ARGV && $ARGV[0] eq 'pserver')
1030 {
1031 print "error 1 pserver access cannot commit\n";
1032 exit;
1033 }
1035 if ( -e $state->{CVSROOT} . "/index" )
1036 {
1037 $log->warn("file 'index' already exists in the git repository");
1038 print "error 1 Index already exists in git repo\n";
1039 exit;
1040 }
1042 # Grab a handle to the SQLite db and do any necessary updates
1043 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1044 $updater->update();
1046 my $tmpdir = tempdir ( DIR => $TEMP_DIR );
1047 my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
1048 $log->info("Lockless commit start, basing commit on '$tmpdir', index file is '$file_index'");
1050 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
1051 $ENV{GIT_INDEX_FILE} = $file_index;
1053 # Remember where the head was at the beginning.
1054 my $parenthash = `git show-ref -s refs/heads/$state->{module}`;
1055 chomp $parenthash;
1056 if ($parenthash !~ /^[0-9a-f]{40}$/) {
1057 print "error 1 pserver cannot find the current HEAD of module";
1058 exit;
1059 }
1061 chdir $tmpdir;
1063 # populate the temporary index based
1064 system("git-read-tree", $parenthash);
1065 unless ($? == 0)
1066 {
1067 die "Error running git-read-tree $state->{module} $file_index $!";
1068 }
1069 $log->info("Created index '$file_index' with for head $state->{module} - exit status $?");
1071 my @committedfiles = ();
1073 # foreach file specified on the command line ...
1074 foreach my $filename ( @{$state->{args}} )
1075 {
1076 my $committedfile = $filename;
1077 $filename = filecleanup($filename);
1079 next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1081 my $meta = $updater->getmeta($filename);
1083 my $wrev = revparse($filename);
1085 my ( $filepart, $dirpart ) = filenamesplit($filename);
1087 # do a checkout of the file if it part of this tree
1088 if ($wrev) {
1089 system('git-checkout-index', '-f', '-u', $filename);
1090 unless ($? == 0) {
1091 die "Error running git-checkout-index -f -u $filename : $!";
1092 }
1093 }
1095 my $addflag = 0;
1096 my $rmflag = 0;
1097 $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
1098 $addflag = 1 unless ( -e $filename );
1100 # Do up to date checking
1101 unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
1102 {
1103 # fail everything if an up to date check fails
1104 print "error 1 Up to date check failed for $filename\n";
1105 chdir "/";
1106 exit;
1107 }
1109 push @committedfiles, $committedfile;
1110 $log->info("Committing $filename");
1112 system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1114 unless ( $rmflag )
1115 {
1116 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1117 rename $state->{entries}{$filename}{modified_filename},$filename;
1119 # Calculate modes to remove
1120 my $invmode = "";
1121 foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1123 $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1124 system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1125 }
1127 if ( $rmflag )
1128 {
1129 $log->info("Removing file '$filename'");
1130 unlink($filename);
1131 system("git-update-index", "--remove", $filename);
1132 }
1133 elsif ( $addflag )
1134 {
1135 $log->info("Adding file '$filename'");
1136 system("git-update-index", "--add", $filename);
1137 } else {
1138 $log->info("Updating file '$filename'");
1139 system("git-update-index", $filename);
1140 }
1141 }
1143 unless ( scalar(@committedfiles) > 0 )
1144 {
1145 print "E No files to commit\n";
1146 print "ok\n";
1147 chdir "/";
1148 return;
1149 }
1151 my $treehash = `git-write-tree`;
1152 chomp $treehash;
1154 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1156 # write our commit message out if we have one ...
1157 my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1158 print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1159 print $msg_fh "\n\nvia git-CVS emulator\n";
1160 close $msg_fh;
1162 my $commithash = `git-commit-tree $treehash -p $parenthash < $msg_filename`;
1163 chomp($commithash);
1164 $log->info("Commit hash : $commithash");
1166 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1167 {
1168 $log->warn("Commit failed (Invalid commit hash)");
1169 print "error 1 Commit failed (unknown reason)\n";
1170 chdir "/";
1171 exit;
1172 }
1174 # Check that this is allowed, just as we would with a receive-pack
1175 my @cmd = ( $ENV{GIT_DIR}.'hooks/update', "refs/heads/$state->{module}",
1176 $parenthash, $commithash );
1177 if( -x $cmd[0] ) {
1178 unless( system( @cmd ) == 0 )
1179 {
1180 $log->warn("Commit failed (update hook declined to update ref)");
1181 print "error 1 Commit failed (update hook declined)\n";
1182 chdir "/";
1183 exit;
1184 }
1185 }
1187 if (system(qw(git update-ref -m), "cvsserver ci",
1188 "refs/heads/$state->{module}", $commithash, $parenthash)) {
1189 $log->warn("update-ref for $state->{module} failed.");
1190 print "error 1 Cannot commit -- update first\n";
1191 exit;
1192 }
1194 $updater->update();
1196 # foreach file specified on the command line ...
1197 foreach my $filename ( @committedfiles )
1198 {
1199 $filename = filecleanup($filename);
1201 my $meta = $updater->getmeta($filename);
1202 unless (defined $meta->{revision}) {
1203 $meta->{revision} = 1;
1204 }
1206 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1208 $log->debug("Checked-in $dirpart : $filename");
1210 if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
1211 {
1212 print "M new revision: delete\n";
1213 print "Remove-entry $dirpart\n";
1214 print "$filename\n";
1215 } else {
1216 if ($meta->{revision} == 1) {
1217 print "M initial revision: 1.1\n";
1218 } else {
1219 print "M new revision: 1.$meta->{revision}\n";
1220 }
1221 print "Checked-in $dirpart\n";
1222 print "$filename\n";
1223 my $kopts = kopts_from_path($filepart);
1224 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1225 }
1226 }
1228 chdir "/";
1229 print "ok\n";
1230 }
1232 sub req_status
1233 {
1234 my ( $cmd, $data ) = @_;
1236 argsplit("status");
1238 $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1239 #$log->debug("status state : " . Dumper($state));
1241 # Grab a handle to the SQLite db and do any necessary updates
1242 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1243 $updater->update();
1245 # if no files were specified, we need to work out what files we should be providing status on ...
1246 argsfromdir($updater);
1248 # foreach file specified on the command line ...
1249 foreach my $filename ( @{$state->{args}} )
1250 {
1251 $filename = filecleanup($filename);
1253 my $meta = $updater->getmeta($filename);
1254 my $oldmeta = $meta;
1256 my $wrev = revparse($filename);
1258 # If the working copy is an old revision, lets get that version too for comparison.
1259 if ( defined($wrev) and $wrev != $meta->{revision} )
1260 {
1261 $oldmeta = $updater->getmeta($filename, $wrev);
1262 }
1264 # TODO : All possible statuses aren't yet implemented
1265 my $status;
1266 # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1267 $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1268 and
1269 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1270 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1271 );
1273 # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1274 $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1275 and
1276 ( $state->{entries}{$filename}{unchanged}
1277 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1278 );
1280 # Need checkout if it exists in the repo but doesn't have a working copy
1281 $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1283 # Locally modified if working copy and repo copy have the same revision but there are local changes
1284 $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1286 # Needs Merge if working copy revision is less than repo copy and there are local changes
1287 $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1289 $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1290 $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1291 $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1292 $status ||= "File had conflicts on merge" if ( 0 );
1294 $status ||= "Unknown";
1296 print "M ===================================================================\n";
1297 print "M File: $filename\tStatus: $status\n";
1298 if ( defined($state->{entries}{$filename}{revision}) )
1299 {
1300 print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1301 } else {
1302 print "M Working revision:\tNo entry for $filename\n";
1303 }
1304 if ( defined($meta->{revision}) )
1305 {
1306 print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{repository}/$filename,v\n";
1307 print "M Sticky Tag:\t\t(none)\n";
1308 print "M Sticky Date:\t\t(none)\n";
1309 print "M Sticky Options:\t\t(none)\n";
1310 } else {
1311 print "M Repository revision:\tNo revision control file\n";
1312 }
1313 print "M\n";
1314 }
1316 print "ok\n";
1317 }
1319 sub req_diff
1320 {
1321 my ( $cmd, $data ) = @_;
1323 argsplit("diff");
1325 $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1326 #$log->debug("status state : " . Dumper($state));
1328 my ($revision1, $revision2);
1329 if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1330 {
1331 $revision1 = $state->{opt}{r}[0];
1332 $revision2 = $state->{opt}{r}[1];
1333 } else {
1334 $revision1 = $state->{opt}{r};
1335 }
1337 $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1338 $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1340 $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1342 # Grab a handle to the SQLite db and do any necessary updates
1343 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1344 $updater->update();
1346 # if no files were specified, we need to work out what files we should be providing status on ...
1347 argsfromdir($updater);
1349 # foreach file specified on the command line ...
1350 foreach my $filename ( @{$state->{args}} )
1351 {
1352 $filename = filecleanup($filename);
1354 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1356 my $wrev = revparse($filename);
1358 # We need _something_ to diff against
1359 next unless ( defined ( $wrev ) );
1361 # if we have a -r switch, use it
1362 if ( defined ( $revision1 ) )
1363 {
1364 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1365 $meta1 = $updater->getmeta($filename, $revision1);
1366 unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1367 {
1368 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1369 next;
1370 }
1371 transmitfile($meta1->{filehash}, $file1);
1372 }
1373 # otherwise we just use the working copy revision
1374 else
1375 {
1376 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1377 $meta1 = $updater->getmeta($filename, $wrev);
1378 transmitfile($meta1->{filehash}, $file1);
1379 }
1381 # if we have a second -r switch, use it too
1382 if ( defined ( $revision2 ) )
1383 {
1384 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1385 $meta2 = $updater->getmeta($filename, $revision2);
1387 unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1388 {
1389 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1390 next;
1391 }
1393 transmitfile($meta2->{filehash}, $file2);
1394 }
1395 # otherwise we just use the working copy
1396 else
1397 {
1398 $file2 = $state->{entries}{$filename}{modified_filename};
1399 }
1401 # if we have been given -r, and we don't have a $file2 yet, lets get one
1402 if ( defined ( $revision1 ) and not defined ( $file2 ) )
1403 {
1404 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1405 $meta2 = $updater->getmeta($filename, $wrev);
1406 transmitfile($meta2->{filehash}, $file2);
1407 }
1409 # We need to have retrieved something useful
1410 next unless ( defined ( $meta1 ) );
1412 # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1413 next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1414 and
1415 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1416 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1417 );
1419 # Apparently we only show diffs for locally modified files
1420 next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1422 print "M Index: $filename\n";
1423 print "M ===================================================================\n";
1424 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1425 print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1426 print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1427 print "M diff ";
1428 foreach my $opt ( keys %{$state->{opt}} )
1429 {
1430 if ( ref $state->{opt}{$opt} eq "ARRAY" )
1431 {
1432 foreach my $value ( @{$state->{opt}{$opt}} )
1433 {
1434 print "-$opt $value ";
1435 }
1436 } else {
1437 print "-$opt ";
1438 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1439 }
1440 }
1441 print "$filename\n";
1443 $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1445 ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1447 if ( exists $state->{opt}{u} )
1448 {
1449 system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1450 } else {
1451 system("diff $file1 $file2 > $filediff");
1452 }
1454 while ( <$fh> )
1455 {
1456 print "M $_";
1457 }
1458 close $fh;
1459 }
1461 print "ok\n";
1462 }
1464 sub req_log
1465 {
1466 my ( $cmd, $data ) = @_;
1468 argsplit("log");
1470 $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1471 #$log->debug("log state : " . Dumper($state));
1473 my ( $minrev, $maxrev );
1474 if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1475 {
1476 my $control = $2;
1477 $minrev = $1;
1478 $maxrev = $3;
1479 $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1480 $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1481 $minrev++ if ( defined($minrev) and $control eq "::" );
1482 }
1484 # Grab a handle to the SQLite db and do any necessary updates
1485 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1486 $updater->update();
1488 # if no files were specified, we need to work out what files we should be providing status on ...
1489 argsfromdir($updater);
1491 # foreach file specified on the command line ...
1492 foreach my $filename ( @{$state->{args}} )
1493 {
1494 $filename = filecleanup($filename);
1496 my $headmeta = $updater->getmeta($filename);
1498 my $revisions = $updater->getlog($filename);
1499 my $totalrevisions = scalar(@$revisions);
1501 if ( defined ( $minrev ) )
1502 {
1503 $log->debug("Removing revisions less than $minrev");
1504 while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1505 {
1506 pop @$revisions;
1507 }
1508 }
1509 if ( defined ( $maxrev ) )
1510 {
1511 $log->debug("Removing revisions greater than $maxrev");
1512 while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1513 {
1514 shift @$revisions;
1515 }
1516 }
1518 next unless ( scalar(@$revisions) );
1520 print "M \n";
1521 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1522 print "M Working file: $filename\n";
1523 print "M head: 1.$headmeta->{revision}\n";
1524 print "M branch:\n";
1525 print "M locks: strict\n";
1526 print "M access list:\n";
1527 print "M symbolic names:\n";
1528 print "M keyword substitution: kv\n";
1529 print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1530 print "M description:\n";
1532 foreach my $revision ( @$revisions )
1533 {
1534 print "M ----------------------------\n";
1535 print "M revision 1.$revision->{revision}\n";
1536 # reformat the date for log output
1537 $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}) );
1538 $revision->{author} =~ s/\s+.*//;
1539 $revision->{author} =~ s/^(.{8}).*/$1/;
1540 print "M date: $revision->{modified}; author: $revision->{author}; state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . "; lines: +2 -3\n";
1541 my $commitmessage = $updater->commitmessage($revision->{commithash});
1542 $commitmessage =~ s/^/M /mg;
1543 print $commitmessage . "\n";
1544 }
1545 print "M =============================================================================\n";
1546 }
1548 print "ok\n";
1549 }
1551 sub req_annotate
1552 {
1553 my ( $cmd, $data ) = @_;
1555 argsplit("annotate");
1557 $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1558 #$log->debug("status state : " . Dumper($state));
1560 # Grab a handle to the SQLite db and do any necessary updates
1561 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1562 $updater->update();
1564 # if no files were specified, we need to work out what files we should be providing annotate on ...
1565 argsfromdir($updater);
1567 # we'll need a temporary checkout dir
1568 my $tmpdir = tempdir ( DIR => $TEMP_DIR );
1569 my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
1570 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$tmpdir', index file is '$file_index'");
1572 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
1573 $ENV{GIT_INDEX_FILE} = $file_index;
1575 chdir $tmpdir;
1577 # foreach file specified on the command line ...
1578 foreach my $filename ( @{$state->{args}} )
1579 {
1580 $filename = filecleanup($filename);
1582 my $meta = $updater->getmeta($filename);
1584 next unless ( $meta->{revision} );
1586 # get all the commits that this file was in
1587 # in dense format -- aka skip dead revisions
1588 my $revisions = $updater->gethistorydense($filename);
1589 my $lastseenin = $revisions->[0][2];
1591 # populate the temporary index based on the latest commit were we saw
1592 # the file -- but do it cheaply without checking out any files
1593 # TODO: if we got a revision from the client, use that instead
1594 # to look up the commithash in sqlite (still good to default to
1595 # the current head as we do now)
1596 system("git-read-tree", $lastseenin);
1597 unless ($? == 0)
1598 {
1599 die "Error running git-read-tree $lastseenin $file_index $!";
1600 }
1601 $log->info("Created index '$file_index' with commit $lastseenin - exit status $?");
1603 # do a checkout of the file
1604 system('git-checkout-index', '-f', '-u', $filename);
1605 unless ($? == 0) {
1606 die "Error running git-checkout-index -f -u $filename : $!";
1607 }
1609 $log->info("Annotate $filename");
1611 # Prepare a file with the commits from the linearized
1612 # history that annotate should know about. This prevents
1613 # git-jsannotate telling us about commits we are hiding
1614 # from the client.
1616 open(ANNOTATEHINTS, ">$tmpdir/.annotate_hints") or die "Error opening > $tmpdir/.annotate_hints $!";
1617 for (my $i=0; $i < @$revisions; $i++)
1618 {
1619 print ANNOTATEHINTS $revisions->[$i][2];
1620 if ($i+1 < @$revisions) { # have we got a parent?
1621 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1622 }
1623 print ANNOTATEHINTS "\n";
1624 }
1626 print ANNOTATEHINTS "\n";
1627 close ANNOTATEHINTS;
1629 my $annotatecmd = 'git-annotate';
1630 open(ANNOTATE, "-|", $annotatecmd, '-l', '-S', "$tmpdir/.annotate_hints", $filename)
1631 or die "Error invoking $annotatecmd -l -S $tmpdir/.annotate_hints $filename : $!";
1632 my $metadata = {};
1633 print "E Annotations for $filename\n";
1634 print "E ***************\n";
1635 while ( <ANNOTATE> )
1636 {
1637 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1638 {
1639 my $commithash = $1;
1640 my $data = $2;
1641 unless ( defined ( $metadata->{$commithash} ) )
1642 {
1643 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1644 $metadata->{$commithash}{author} =~ s/\s+.*//;
1645 $metadata->{$commithash}{author} =~ s/^(.{8}).*/$1/;
1646 $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1647 }
1648 printf("M 1.%-5d (%-8s %10s): %s\n",
1649 $metadata->{$commithash}{revision},
1650 $metadata->{$commithash}{author},
1651 $metadata->{$commithash}{modified},
1652 $data
1653 );
1654 } else {
1655 $log->warn("Error in annotate output! LINE: $_");
1656 print "E Annotate error \n";
1657 next;
1658 }
1659 }
1660 close ANNOTATE;
1661 }
1663 # done; get out of the tempdir
1664 chdir "/";
1666 print "ok\n";
1668 }
1670 # This method takes the state->{arguments} array and produces two new arrays.
1671 # The first is $state->{args} which is everything before the '--' argument, and
1672 # the second is $state->{files} which is everything after it.
1673 sub argsplit
1674 {
1675 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
1677 my $type = shift;
1679 $state->{args} = [];
1680 $state->{files} = [];
1681 $state->{opt} = {};
1683 if ( defined($type) )
1684 {
1685 my $opt = {};
1686 $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" );
1687 $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
1688 $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" );
1689 $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
1690 $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
1691 $opt = { k => 1, m => 1 } if ( $type eq "add" );
1692 $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
1693 $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" );
1696 while ( scalar ( @{$state->{arguments}} ) > 0 )
1697 {
1698 my $arg = shift @{$state->{arguments}};
1700 next if ( $arg eq "--" );
1701 next unless ( $arg =~ /\S/ );
1703 # if the argument looks like a switch
1704 if ( $arg =~ /^-(\w)(.*)/ )
1705 {
1706 # if it's a switch that takes an argument
1707 if ( $opt->{$1} )
1708 {
1709 # If this switch has already been provided
1710 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
1711 {
1712 $state->{opt}{$1} = [ $state->{opt}{$1} ];
1713 if ( length($2) > 0 )
1714 {
1715 push @{$state->{opt}{$1}},$2;
1716 } else {
1717 push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
1718 }
1719 } else {
1720 # if there's extra data in the arg, use that as the argument for the switch
1721 if ( length($2) > 0 )
1722 {
1723 $state->{opt}{$1} = $2;
1724 } else {
1725 $state->{opt}{$1} = shift @{$state->{arguments}};
1726 }
1727 }
1728 } else {
1729 $state->{opt}{$1} = undef;
1730 }
1731 }
1732 else
1733 {
1734 push @{$state->{args}}, $arg;
1735 }
1736 }
1737 }
1738 else
1739 {
1740 my $mode = 0;
1742 foreach my $value ( @{$state->{arguments}} )
1743 {
1744 if ( $value eq "--" )
1745 {
1746 $mode++;
1747 next;
1748 }
1749 push @{$state->{args}}, $value if ( $mode == 0 );
1750 push @{$state->{files}}, $value if ( $mode == 1 );
1751 }
1752 }
1753 }
1755 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
1756 sub argsfromdir
1757 {
1758 my $updater = shift;
1760 $state->{args} = [] if ( scalar(@{$state->{args}}) == 1 and $state->{args}[0] eq "." );
1762 return if ( scalar ( @{$state->{args}} ) > 1 );
1764 my @gethead = @{$updater->gethead};
1766 # push added files
1767 foreach my $file (keys %{$state->{entries}}) {
1768 if ( exists $state->{entries}{$file}{revision} &&
1769 $state->{entries}{$file}{revision} == 0 )
1770 {
1771 push @gethead, { name => $file, filehash => 'added' };
1772 }
1773 }
1775 if ( scalar(@{$state->{args}}) == 1 )
1776 {
1777 my $arg = $state->{args}[0];
1778 $arg .= $state->{prependdir} if ( defined ( $state->{prependdir} ) );
1780 $log->info("Only one arg specified, checking for directory expansion on '$arg'");
1782 foreach my $file ( @gethead )
1783 {
1784 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1785 next unless ( $file->{name} =~ /^$arg\// or $file->{name} eq $arg );
1786 push @{$state->{args}}, $file->{name};
1787 }
1789 shift @{$state->{args}} if ( scalar(@{$state->{args}}) > 1 );
1790 } else {
1791 $log->info("Only one arg specified, populating file list automatically");
1793 $state->{args} = [];
1795 foreach my $file ( @gethead )
1796 {
1797 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1798 next unless ( $file->{name} =~ s/^$state->{prependdir}// );
1799 push @{$state->{args}}, $file->{name};
1800 }
1801 }
1802 }
1804 # This method cleans up the $state variable after a command that uses arguments has run
1805 sub statecleanup
1806 {
1807 $state->{files} = [];
1808 $state->{args} = [];
1809 $state->{arguments} = [];
1810 $state->{entries} = {};
1811 }
1813 sub revparse
1814 {
1815 my $filename = shift;
1817 return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
1819 return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
1820 return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
1822 return undef;
1823 }
1825 # This method takes a file hash and does a CVS "file transfer" which transmits the
1826 # size of the file, and then the file contents.
1827 # If a second argument $targetfile is given, the file is instead written out to
1828 # a file by the name of $targetfile
1829 sub transmitfile
1830 {
1831 my $filehash = shift;
1832 my $targetfile = shift;
1834 if ( defined ( $filehash ) and $filehash eq "deleted" )
1835 {
1836 $log->warn("filehash is 'deleted'");
1837 return;
1838 }
1840 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
1842 my $type = `git-cat-file -t $filehash`;
1843 chomp $type;
1845 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
1847 my $size = `git-cat-file -s $filehash`;
1848 chomp $size;
1850 $log->debug("transmitfile($filehash) size=$size, type=$type");
1852 if ( open my $fh, '-|', "git-cat-file", "blob", $filehash )
1853 {
1854 if ( defined ( $targetfile ) )
1855 {
1856 open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
1857 print NEWFILE $_ while ( <$fh> );
1858 close NEWFILE;
1859 } else {
1860 print "$size\n";
1861 print while ( <$fh> );
1862 }
1863 close $fh or die ("Couldn't close filehandle for transmitfile()");
1864 } else {
1865 die("Couldn't execute git-cat-file");
1866 }
1867 }
1869 # This method takes a file name, and returns ( $dirpart, $filepart ) which
1870 # refers to the directory portion and the file portion of the filename
1871 # respectively
1872 sub filenamesplit
1873 {
1874 my $filename = shift;
1875 my $fixforlocaldir = shift;
1877 my ( $filepart, $dirpart ) = ( $filename, "." );
1878 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
1879 $dirpart .= "/";
1881 if ( $fixforlocaldir )
1882 {
1883 $dirpart =~ s/^$state->{prependdir}//;
1884 }
1886 return ( $filepart, $dirpart );
1887 }
1889 sub filecleanup
1890 {
1891 my $filename = shift;
1893 return undef unless(defined($filename));
1894 if ( $filename =~ /^\// )
1895 {
1896 print "E absolute filenames '$filename' not supported by server\n";
1897 return undef;
1898 }
1900 $filename =~ s/^\.\///g;
1901 $filename = $state->{prependdir} . $filename;
1902 return $filename;
1903 }
1905 # Given a path, this function returns a string containing the kopts
1906 # that should go into that path's Entries line. For example, a binary
1907 # file should get -kb.
1908 sub kopts_from_path
1909 {
1910 my ($path) = @_;
1912 # Once it exists, the git attributes system should be used to look up
1913 # what attributes apply to this path.
1915 # Until then, take the setting from the config file
1916 unless ( defined ( $cfg->{gitcvs}{allbinary} ) and $cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i )
1917 {
1918 # Return "" to give no special treatment to any path
1919 return "";
1920 } else {
1921 # Alternatively, to have all files treated as if they are binary (which
1922 # is more like git itself), always return the "-kb" option
1923 return "-kb";
1924 }
1925 }
1927 package GITCVS::log;
1929 ####
1930 #### Copyright The Open University UK - 2006.
1931 ####
1932 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
1933 #### Martin Langhoff <martin@catalyst.net.nz>
1934 ####
1935 ####
1937 use strict;
1938 use warnings;
1940 =head1 NAME
1942 GITCVS::log
1944 =head1 DESCRIPTION
1946 This module provides very crude logging with a similar interface to
1947 Log::Log4perl
1949 =head1 METHODS
1951 =cut
1953 =head2 new
1955 Creates a new log object, optionally you can specify a filename here to
1956 indicate the file to log to. If no log file is specified, you can specify one
1957 later with method setfile, or indicate you no longer want logging with method
1958 nofile.
1960 Until one of these methods is called, all log calls will buffer messages ready
1961 to write out.
1963 =cut
1964 sub new
1965 {
1966 my $class = shift;
1967 my $filename = shift;
1969 my $self = {};
1971 bless $self, $class;
1973 if ( defined ( $filename ) )
1974 {
1975 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
1976 }
1978 return $self;
1979 }
1981 =head2 setfile
1983 This methods takes a filename, and attempts to open that file as the log file.
1984 If successful, all buffered data is written out to the file, and any further
1985 logging is written directly to the file.
1987 =cut
1988 sub setfile
1989 {
1990 my $self = shift;
1991 my $filename = shift;
1993 if ( defined ( $filename ) )
1994 {
1995 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
1996 }
1998 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2000 while ( my $line = shift @{$self->{buffer}} )
2001 {
2002 print {$self->{fh}} $line;
2003 }
2004 }
2006 =head2 nofile
2008 This method indicates no logging is going to be used. It flushes any entries in
2009 the internal buffer, and sets a flag to ensure no further data is put there.
2011 =cut
2012 sub nofile
2013 {
2014 my $self = shift;
2016 $self->{nolog} = 1;
2018 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2020 $self->{buffer} = [];
2021 }
2023 =head2 _logopen
2025 Internal method. Returns true if the log file is open, false otherwise.
2027 =cut
2028 sub _logopen
2029 {
2030 my $self = shift;
2032 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
2033 return 0;
2034 }
2036 =head2 debug info warn fatal
2038 These four methods are wrappers to _log. They provide the actual interface for
2039 logging data.
2041 =cut
2042 sub debug { my $self = shift; $self->_log("debug", @_); }
2043 sub info { my $self = shift; $self->_log("info" , @_); }
2044 sub warn { my $self = shift; $self->_log("warn" , @_); }
2045 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2047 =head2 _log
2049 This is an internal method called by the logging functions. It generates a
2050 timestamp and pushes the logged line either to file, or internal buffer.
2052 =cut
2053 sub _log
2054 {
2055 my $self = shift;
2056 my $level = shift;
2058 return if ( $self->{nolog} );
2060 my @time = localtime;
2061 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2062 $time[5] + 1900,
2063 $time[4] + 1,
2064 $time[3],
2065 $time[2],
2066 $time[1],
2067 $time[0],
2068 uc $level,
2069 );
2071 if ( $self->_logopen )
2072 {
2073 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2074 } else {
2075 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2076 }
2077 }
2079 =head2 DESTROY
2081 This method simply closes the file handle if one is open
2083 =cut
2084 sub DESTROY
2085 {
2086 my $self = shift;
2088 if ( $self->_logopen )
2089 {
2090 close $self->{fh};
2091 }
2092 }
2094 package GITCVS::updater;
2096 ####
2097 #### Copyright The Open University UK - 2006.
2098 ####
2099 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2100 #### Martin Langhoff <martin@catalyst.net.nz>
2101 ####
2102 ####
2104 use strict;
2105 use warnings;
2106 use DBI;
2108 =head1 METHODS
2110 =cut
2112 =head2 new
2114 =cut
2115 sub new
2116 {
2117 my $class = shift;
2118 my $config = shift;
2119 my $module = shift;
2120 my $log = shift;
2122 die "Need to specify a git repository" unless ( defined($config) and -d $config );
2123 die "Need to specify a module" unless ( defined($module) );
2125 $class = ref($class) || $class;
2127 my $self = {};
2129 bless $self, $class;
2131 $self->{dbdir} = $config . "/";
2132 die "Database dir '$self->{dbdir}' isn't a directory" unless ( defined($self->{dbdir}) and -d $self->{dbdir} );
2134 $self->{module} = $module;
2135 $self->{file} = $self->{dbdir} . "/gitcvs.$module.sqlite";
2137 $self->{git_path} = $config . "/";
2139 $self->{log} = $log;
2141 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2143 $self->{dbh} = DBI->connect("dbi:SQLite:dbname=" . $self->{file},"","");
2145 $self->{tables} = {};
2146 foreach my $table ( $self->{dbh}->tables )
2147 {
2148 $table =~ s/^"//;
2149 $table =~ s/"$//;
2150 $self->{tables}{$table} = 1;
2151 }
2153 # Construct the revision table if required
2154 unless ( $self->{tables}{revision} )
2155 {
2156 $self->{dbh}->do("
2157 CREATE TABLE revision (
2158 name TEXT NOT NULL,
2159 revision INTEGER NOT NULL,
2160 filehash TEXT NOT NULL,
2161 commithash TEXT NOT NULL,
2162 author TEXT NOT NULL,
2163 modified TEXT NOT NULL,
2164 mode TEXT NOT NULL
2165 )
2166 ");
2167 $self->{dbh}->do("
2168 CREATE INDEX revision_ix1
2169 ON revision (name,revision)
2170 ");
2171 $self->{dbh}->do("
2172 CREATE INDEX revision_ix2
2173 ON revision (name,commithash)
2174 ");
2175 }
2177 # Construct the head table if required
2178 unless ( $self->{tables}{head} )
2179 {
2180 $self->{dbh}->do("
2181 CREATE TABLE head (
2182 name TEXT NOT NULL,
2183 revision INTEGER NOT NULL,
2184 filehash TEXT NOT NULL,
2185 commithash TEXT NOT NULL,
2186 author TEXT NOT NULL,
2187 modified TEXT NOT NULL,
2188 mode TEXT NOT NULL
2189 )
2190 ");
2191 $self->{dbh}->do("
2192 CREATE INDEX head_ix1
2193 ON head (name)
2194 ");
2195 }
2197 # Construct the properties table if required
2198 unless ( $self->{tables}{properties} )
2199 {
2200 $self->{dbh}->do("
2201 CREATE TABLE properties (
2202 key TEXT NOT NULL PRIMARY KEY,
2203 value TEXT
2204 )
2205 ");
2206 }
2208 # Construct the commitmsgs table if required
2209 unless ( $self->{tables}{commitmsgs} )
2210 {
2211 $self->{dbh}->do("
2212 CREATE TABLE commitmsgs (
2213 key TEXT NOT NULL PRIMARY KEY,
2214 value TEXT
2215 )
2216 ");
2217 }
2219 return $self;
2220 }
2222 =head2 update
2224 =cut
2225 sub update
2226 {
2227 my $self = shift;
2229 # first lets get the commit list
2230 $ENV{GIT_DIR} = $self->{git_path};
2232 my $commitsha1 = `git rev-parse $self->{module}`;
2233 chomp $commitsha1;
2235 my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
2236 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
2237 {
2238 die("Invalid module '$self->{module}'");
2239 }
2242 my $git_log;
2243 my $lastcommit = $self->_get_prop("last_commit");
2245 if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
2246 return 1;
2247 }
2249 # Start exclusive lock here...
2250 $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
2252 # TODO: log processing is memory bound
2253 # if we can parse into a 2nd file that is in reverse order
2254 # we can probably do something really efficient
2255 my @git_log_params = ('--pretty', '--parents', '--topo-order');
2257 if (defined $lastcommit) {
2258 push @git_log_params, "$lastcommit..$self->{module}";
2259 } else {
2260 push @git_log_params, $self->{module};
2261 }
2262 # git-rev-list is the backend / plumbing version of git-log
2263 open(GITLOG, '-|', 'git-rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
2265 my @commits;
2267 my %commit = ();
2269 while ( <GITLOG> )
2270 {
2271 chomp;
2272 if (m/^commit\s+(.*)$/) {
2273 # on ^commit lines put the just seen commit in the stack
2274 # and prime things for the next one
2275 if (keys %commit) {
2276 my %copy = %commit;
2277 unshift @commits, \%copy;
2278 %commit = ();
2279 }
2280 my @parents = split(m/\s+/, $1);
2281 $commit{hash} = shift @parents;
2282 $commit{parents} = \@parents;
2283 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
2284 # on rfc822-like lines seen before we see any message,
2285 # lowercase the entry and put it in the hash as key-value
2286 $commit{lc($1)} = $2;
2287 } else {
2288 # message lines - skip initial empty line
2289 # and trim whitespace
2290 if (!exists($commit{message}) && m/^\s*$/) {
2291 # define it to mark the end of headers
2292 $commit{message} = '';
2293 next;
2294 }
2295 s/^\s+//; s/\s+$//; # trim ws
2296 $commit{message} .= $_ . "\n";
2297 }
2298 }
2299 close GITLOG;
2301 unshift @commits, \%commit if ( keys %commit );
2303 # Now all the commits are in the @commits bucket
2304 # ordered by time DESC. for each commit that needs processing,
2305 # determine whether it's following the last head we've seen or if
2306 # it's on its own branch, grab a file list, and add whatever's changed
2307 # NOTE: $lastcommit refers to the last commit from previous run
2308 # $lastpicked is the last commit we picked in this run
2309 my $lastpicked;
2310 my $head = {};
2311 if (defined $lastcommit) {
2312 $lastpicked = $lastcommit;
2313 }
2315 my $committotal = scalar(@commits);
2316 my $commitcount = 0;
2318 # Load the head table into $head (for cached lookups during the update process)
2319 foreach my $file ( @{$self->gethead()} )
2320 {
2321 $head->{$file->{name}} = $file;
2322 }
2324 foreach my $commit ( @commits )
2325 {
2326 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
2327 if (defined $lastpicked)
2328 {
2329 if (!in_array($lastpicked, @{$commit->{parents}}))
2330 {
2331 # skip, we'll see this delta
2332 # as part of a merge later
2333 # warn "skipping off-track $commit->{hash}\n";
2334 next;
2335 } elsif (@{$commit->{parents}} > 1) {
2336 # it is a merge commit, for each parent that is
2337 # not $lastpicked, see if we can get a log
2338 # from the merge-base to that parent to put it
2339 # in the message as a merge summary.
2340 my @parents = @{$commit->{parents}};
2341 foreach my $parent (@parents) {
2342 # git-merge-base can potentially (but rarely) throw
2343 # several candidate merge bases. let's assume
2344 # that the first one is the best one.
2345 if ($parent eq $lastpicked) {
2346 next;
2347 }
2348 open my $p, 'git-merge-base '. $lastpicked . ' '
2349 . $parent . '|';
2350 my @output = (<$p>);
2351 close $p;
2352 my $base = join('', @output);
2353 chomp $base;
2354 if ($base) {
2355 my @merged;
2356 # print "want to log between $base $parent \n";
2357 open(GITLOG, '-|', 'git-log', "$base..$parent")
2358 or die "Cannot call git-log: $!";
2359 my $mergedhash;
2360 while (<GITLOG>) {
2361 chomp;
2362 if (!defined $mergedhash) {
2363 if (m/^commit\s+(.+)$/) {
2364 $mergedhash = $1;
2365 } else {
2366 next;
2367 }
2368 } else {
2369 # grab the first line that looks non-rfc822
2370 # aka has content after leading space
2371 if (m/^\s+(\S.*)$/) {
2372 my $title = $1;
2373 $title = substr($title,0,100); # truncate
2374 unshift @merged, "$mergedhash $title";
2375 undef $mergedhash;
2376 }
2377 }
2378 }
2379 close GITLOG;
2380 if (@merged) {
2381 $commit->{mergemsg} = $commit->{message};
2382 $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
2383 foreach my $summary (@merged) {
2384 $commit->{mergemsg} .= "\t$summary\n";
2385 }
2386 $commit->{mergemsg} .= "\n\n";
2387 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
2388 }
2389 }
2390 }
2391 }
2392 }
2394 # convert the date to CVS-happy format
2395 $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
2397 if ( defined ( $lastpicked ) )
2398 {
2399 my $filepipe = open(FILELIST, '-|', 'git-diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
2400 local ($/) = "\0";
2401 while ( <FILELIST> )
2402 {
2403 chomp;
2404 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
2405 {
2406 die("Couldn't process git-diff-tree line : $_");
2407 }
2408 my ($mode, $hash, $change) = ($1, $2, $3);
2409 my $name = <FILELIST>;
2410 chomp($name);
2412 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
2414 my $git_perms = "";
2415 $git_perms .= "r" if ( $mode & 4 );
2416 $git_perms .= "w" if ( $mode & 2 );
2417 $git_perms .= "x" if ( $mode & 1 );
2418 $git_perms = "rw" if ( $git_perms eq "" );
2420 if ( $change eq "D" )
2421 {
2422 #$log->debug("DELETE $name");
2423 $head->{$name} = {
2424 name => $name,
2425 revision => $head->{$name}{revision} + 1,
2426 filehash => "deleted",
2427 commithash => $commit->{hash},
2428 modified => $commit->{date},
2429 author => $commit->{author},
2430 mode => $git_perms,
2431 };
2432 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2433 }
2434 elsif ( $change eq "M" )
2435 {
2436 #$log->debug("MODIFIED $name");
2437 $head->{$name} = {
2438 name => $name,
2439 revision => $head->{$name}{revision} + 1,
2440 filehash => $hash,
2441 commithash => $commit->{hash},
2442 modified => $commit->{date},
2443 author => $commit->{author},
2444 mode => $git_perms,
2445 };
2446 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2447 }
2448 elsif ( $change eq "A" )
2449 {
2450 #$log->debug("ADDED $name");
2451 $head->{$name} = {
2452 name => $name,
2453 revision => 1,
2454 filehash => $hash,
2455 commithash => $commit->{hash},
2456 modified => $commit->{date},
2457 author => $commit->{author},
2458 mode => $git_perms,
2459 };
2460 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2461 }
2462 else
2463 {
2464 $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
2465 die;
2466 }
2467 }
2468 close FILELIST;
2469 } else {
2470 # this is used to detect files removed from the repo
2471 my $seen_files = {};
2473 my $filepipe = open(FILELIST, '-|', 'git-ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
2474 local $/ = "\0";
2475 while ( <FILELIST> )
2476 {
2477 chomp;
2478 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
2479 {
2480 die("Couldn't process git-ls-tree line : $_");
2481 }
2483 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
2485 $seen_files->{$git_filename} = 1;
2487 my ( $oldhash, $oldrevision, $oldmode ) = (
2488 $head->{$git_filename}{filehash},
2489 $head->{$git_filename}{revision},
2490 $head->{$git_filename}{mode}
2491 );
2493 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
2494 {
2495 $git_perms = "";
2496 $git_perms .= "r" if ( $1 & 4 );
2497 $git_perms .= "w" if ( $1 & 2 );
2498 $git_perms .= "x" if ( $1 & 1 );
2499 } else {
2500 $git_perms = "rw";
2501 }
2503 # unless the file exists with the same hash, we need to update it ...
2504 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
2505 {
2506 my $newrevision = ( $oldrevision or 0 ) + 1;
2508 $head->{$git_filename} = {
2509 name => $git_filename,
2510 revision => $newrevision,
2511 filehash => $git_hash,
2512 commithash => $commit->{hash},
2513 modified => $commit->{date},
2514 author => $commit->{author},
2515 mode => $git_perms,
2516 };
2519 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2520 }
2521 }
2522 close FILELIST;
2524 # Detect deleted files
2525 foreach my $file ( keys %$head )
2526 {
2527 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
2528 {
2529 $head->{$file}{revision}++;
2530 $head->{$file}{filehash} = "deleted";
2531 $head->{$file}{commithash} = $commit->{hash};
2532 $head->{$file}{modified} = $commit->{date};
2533 $head->{$file}{author} = $commit->{author};
2535 $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
2536 }
2537 }
2538 # END : "Detect deleted files"
2539 }
2542 if (exists $commit->{mergemsg})
2543 {
2544 $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
2545 }
2547 $lastpicked = $commit->{hash};
2549 $self->_set_prop("last_commit", $commit->{hash});
2550 }
2552 $self->delete_head();
2553 foreach my $file ( keys %$head )
2554 {
2555 $self->insert_head(
2556 $file,
2557 $head->{$file}{revision},
2558 $head->{$file}{filehash},
2559 $head->{$file}{commithash},
2560 $head->{$file}{modified},
2561 $head->{$file}{author},
2562 $head->{$file}{mode},
2563 );
2564 }
2565 # invalidate the gethead cache
2566 $self->{gethead_cache} = undef;
2569 # Ending exclusive lock here
2570 $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
2571 }
2573 sub insert_rev
2574 {
2575 my $self = shift;
2576 my $name = shift;
2577 my $revision = shift;
2578 my $filehash = shift;
2579 my $commithash = shift;
2580 my $modified = shift;
2581 my $author = shift;
2582 my $mode = shift;
2584 my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO revision (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2585 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
2586 }
2588 sub insert_mergelog
2589 {
2590 my $self = shift;
2591 my $key = shift;
2592 my $value = shift;
2594 my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO commitmsgs (key, value) VALUES (?,?)",{},1);
2595 $insert_mergelog->execute($key, $value);
2596 }
2598 sub delete_head
2599 {
2600 my $self = shift;
2602 my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM head",{},1);
2603 $delete_head->execute();
2604 }
2606 sub insert_head
2607 {
2608 my $self = shift;
2609 my $name = shift;
2610 my $revision = shift;
2611 my $filehash = shift;
2612 my $commithash = shift;
2613 my $modified = shift;
2614 my $author = shift;
2615 my $mode = shift;
2617 my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO head (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2618 $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
2619 }
2621 sub _headrev
2622 {
2623 my $self = shift;
2624 my $filename = shift;
2626 my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM head WHERE name=?",{},1);
2627 $db_query->execute($filename);
2628 my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
2630 return ( $hash, $revision, $mode );
2631 }
2633 sub _get_prop
2634 {
2635 my $self = shift;
2636 my $key = shift;
2638 my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM properties WHERE key=?",{},1);
2639 $db_query->execute($key);
2640 my ( $value ) = $db_query->fetchrow_array;
2642 return $value;
2643 }
2645 sub _set_prop
2646 {
2647 my $self = shift;
2648 my $key = shift;
2649 my $value = shift;
2651 my $db_query = $self->{dbh}->prepare_cached("UPDATE properties SET value=? WHERE key=?",{},1);
2652 $db_query->execute($value, $key);
2654 unless ( $db_query->rows )
2655 {
2656 $db_query = $self->{dbh}->prepare_cached("INSERT INTO properties (key, value) VALUES (?,?)",{},1);
2657 $db_query->execute($key, $value);
2658 }
2660 return $value;
2661 }
2663 =head2 gethead
2665 =cut
2667 sub gethead
2668 {
2669 my $self = shift;
2671 return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
2673 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM head ORDER BY name ASC",{},1);
2674 $db_query->execute();
2676 my $tree = [];
2677 while ( my $file = $db_query->fetchrow_hashref )
2678 {
2679 push @$tree, $file;
2680 }
2682 $self->{gethead_cache} = $tree;
2684 return $tree;
2685 }
2687 =head2 getlog
2689 =cut
2691 sub getlog
2692 {
2693 my $self = shift;
2694 my $filename = shift;
2696 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2697 $db_query->execute($filename);
2699 my $tree = [];
2700 while ( my $file = $db_query->fetchrow_hashref )
2701 {
2702 push @$tree, $file;
2703 }
2705 return $tree;
2706 }
2708 =head2 getmeta
2710 This function takes a filename (with path) argument and returns a hashref of
2711 metadata for that file.
2713 =cut
2715 sub getmeta
2716 {
2717 my $self = shift;
2718 my $filename = shift;
2719 my $revision = shift;
2721 my $db_query;
2722 if ( defined($revision) and $revision =~ /^\d+$/ )
2723 {
2724 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND revision=?",{},1);
2725 $db_query->execute($filename, $revision);
2726 }
2727 elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
2728 {
2729 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND commithash=?",{},1);
2730 $db_query->execute($filename, $revision);
2731 } else {
2732 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM head WHERE name=?",{},1);
2733 $db_query->execute($filename);
2734 }
2736 return $db_query->fetchrow_hashref;
2737 }
2739 =head2 commitmessage
2741 this function takes a commithash and returns the commit message for that commit
2743 =cut
2744 sub commitmessage
2745 {
2746 my $self = shift;
2747 my $commithash = shift;
2749 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
2751 my $db_query;
2752 $db_query = $self->{dbh}->prepare_cached("SELECT value FROM commitmsgs WHERE key=?",{},1);
2753 $db_query->execute($commithash);
2755 my ( $message ) = $db_query->fetchrow_array;
2757 if ( defined ( $message ) )
2758 {
2759 $message .= " " if ( $message =~ /\n$/ );
2760 return $message;
2761 }
2763 my @lines = safe_pipe_capture("git-cat-file", "commit", $commithash);
2764 shift @lines while ( $lines[0] =~ /\S/ );
2765 $message = join("",@lines);
2766 $message .= " " if ( $message =~ /\n$/ );
2767 return $message;
2768 }
2770 =head2 gethistory
2772 This function takes a filename (with path) argument and returns an arrayofarrays
2773 containing revision,filehash,commithash ordered by revision descending
2775 =cut
2776 sub gethistory
2777 {
2778 my $self = shift;
2779 my $filename = shift;
2781 my $db_query;
2782 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2783 $db_query->execute($filename);
2785 return $db_query->fetchall_arrayref;
2786 }
2788 =head2 gethistorydense
2790 This function takes a filename (with path) argument and returns an arrayofarrays
2791 containing revision,filehash,commithash ordered by revision descending.
2793 This version of gethistory skips deleted entries -- so it is useful for annotate.
2794 The 'dense' part is a reference to a '--dense' option available for git-rev-list
2795 and other git tools that depend on it.
2797 =cut
2798 sub gethistorydense
2799 {
2800 my $self = shift;
2801 my $filename = shift;
2803 my $db_query;
2804 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
2805 $db_query->execute($filename);
2807 return $db_query->fetchall_arrayref;
2808 }
2810 =head2 in_array()
2812 from Array::PAT - mimics the in_array() function
2813 found in PHP. Yuck but works for small arrays.
2815 =cut
2816 sub in_array
2817 {
2818 my ($check, @array) = @_;
2819 my $retval = 0;
2820 foreach my $test (@array){
2821 if($check eq $test){
2822 $retval = 1;
2823 }
2824 }
2825 return $retval;
2826 }
2828 =head2 safe_pipe_capture
2830 an alternative to `command` that allows input to be passed as an array
2831 to work around shell problems with weird characters in arguments
2833 =cut
2834 sub safe_pipe_capture {
2836 my @output;
2838 if (my $pid = open my $child, '-|') {
2839 @output = (<$child>);
2840 close $child or die join(' ',@_).": $! $?";
2841 } else {
2842 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
2843 }
2844 return wantarray ? @output : join('',@output);
2845 }
2848 1;