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