info: learns -json option

2 files changed, 228 insertions, 9 deletions

diff --git a/src/commands/info b/src/commands/info
index b2bc3fc..3a2d463 100755
--- a/src/commands/info
+++ b/src/commands/info
@@ -10,50 +10,72 @@ use Gitolite::Common;
 use Gitolite::Conf::Load;
 
 =for args
-Usage:  gitolite info [-lc] [-ld] [<repo name pattern>]
+Usage:  gitolite info [-lc] [-ld] [-json] [<repo name pattern>]
 
 List all existing repos you can access, as well as repo name patterns you can
 create repos from (if any).
 
     '-lc'       lists creators as an additional field at the end.
     '-ld'       lists description as an additional field at the end.
+    '-json'     produce JSON output instead of normal output
 
 The optional pattern is an unanchored regex that will limit the repos
 searched, in both cases.  It might speed up things a little if you have more
 than a few thousand repos.
 =cut
 
-# these two are globals
-my ( $lc, $ld, $patt ) = args();
+# these are globals
+my ( $lc, $ld, $json, $patt ) = args();
+my %out;    # holds info to be json'd
 
 print_version();
 
 print_patterns();     # repos he can create for himself
 print_phy_repos();    # repos already created
-print "\n$rc{SITE_INFO}\n" if $rc{SITE_INFO};
+
+if ( $rc{SITE_INFO} ) {
+    $json
+      ? $out{SITE_INFO} = $rc{SITE_INFO}
+      : print "\n$rc{SITE_INFO}\n";
+}
+
+print JSON::to_json( \%out, { utf8 => 1, pretty => 1 } ) if $json;
 
 # ----------------------------------------------------------------------
 
 sub args {
-    my ( $lc, $ld, $patt ) = ( '', '', '' );
+    my ( $lc, $ld, $json, $patt ) = ( '', '', '', '' );
     my $help = '';
 
     GetOptions(
-        'lc' => \$lc,
-        'ld' => \$ld,
-        'h'  => \$help,
+        'lc'   => \$lc,
+        'ld'   => \$ld,
+        'json' => \$json,
+        'h'    => \$help,
     ) or usage();
 
     usage() if @ARGV > 1 or $help;
     $patt = shift @ARGV || '.';
 
-    return ( $lc, $ld, $patt );
+    require JSON if $json;
+
+    return ( $lc, $ld, $json, $patt );
 }
 
 sub print_version {
     chomp( my $hn = `hostname -s 2>/dev/null || hostname` );
     my $gv = substr( `git --version`, 12 );
     $ENV{GL_USER} or _die "GL_USER not set";
+
+    if ($json) {
+        $out{GL_USER}          = $ENV{GL_USER};
+        $out{USER}             = ( $ENV{USER} || "httpd" ) . "\@$hn";
+        $out{gitolite_version} = version();
+        chomp( $out{git_version} = $gv );    # this thing has a newline at the end
+        return;
+    }
+
+    # normal output
     print "hello $ENV{GL_USER}, this is " . ( $ENV{USER} || "httpd" ) . "\@$hn running gitolite3 " . version() . " on git $gv\n";
 }
 
@@ -100,6 +122,15 @@ sub listem {
         }
         $perm =~ s/\^//;
         next unless $perm =~ /\S/;
+
+        if ($json) {
+            $out{repos}{$repo}{creator}     = $creator if $lc;
+            $out{repos}{$repo}{description} = $desc    if $ld;
+            $out{repos}{$repo}{perms}       = _hash($perm);
+
+            next;
+        }
+
         print "$perm\t$repo";
         print "\t$creator" if $lc;
         print "\t$desc"    if $ld;
@@ -107,3 +138,8 @@ sub listem {
     }
 }
 
+sub _hash {
+    my $in = shift;
+    my %out = map { $_ => 1 } ( $in =~ /(\S)/g );
+    return \%out;
+}
diff --git a/t/info-json.t b/t/info-json.t
new file mode 100755
index 0000000..a78b79f
--- /dev/null
+++ b/t/info-json.t
@@ -0,0 +1,183 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+# this is hardcoded; change it if needed
+use lib "src/lib";
+use Gitolite::Test;
+use JSON;
+
+# the info command
+# ----------------------------------------------------------------------
+
+try 'plan 162';
+
+try "## info";
+
+confreset;confadd '
+    @t1 = t1
+    repo    @t1
+        RW              =   u1
+        R               =   u2
+    repo    t2
+        RW  =               u2
+        R   =               u1
+    repo    t3
+        RW  =   u3
+        R   =   u4
+
+    repo foo/..*
+        C   =   u1
+        RW  =   CREATOR u3
+';
+
+try "ADMIN_PUSH info; !/FATAL/" or die text();
+try "
+                                        /Initialized.*empty.*t1.git/
+                                        /Initialized.*empty.*t2.git/
+                                        /Initialized.*empty.*t3.git/
+";
+
+my $href;   # semi-global (or at least file scoped lexical!)
+
+# testing for info -json is a bit unusual.  The actual tests are done within
+# this test script itself, and we send Tsh just enough for it to decide if
+# it's 'ok' or 'not ok' and print that.
+
+try "glt info u1 -json; ok";
+$href = from_json(text());
+try "## u1 test_gs";
+test_gs('u1');
+try "## u1";
+perm('foo/..*', 'r w C');
+perm('testing', 'R W c');
+perm('t1', 'R W c');
+perm('t2', 'R w c');
+perm('t3', 'r w c');
+
+try "## u2";
+try "glt info u2 -json; ok";
+$href = from_json(text());
+perm('foo/..*', 'r w c');
+perm('testing', 'R W c');
+perm('t1', 'R w c');
+perm('t2', 'R W c');
+perm('t3', 'r w c');
+
+try "## u3";
+try "glt info u3 -json; ok";
+$href = from_json(text());
+perm('foo/..*', 'R W c');
+perm('testing', 'R W c');
+perm('t1', 'r w c');
+perm('t2', 'r w c');
+perm('t3', 'R W c');
+
+try "## u4";
+try "glt info u4 -json; ok";
+$href = from_json(text());
+perm('foo/..*', 'r w c');
+perm('testing', 'R W c');
+perm('t1', 'r w c');
+perm('t2', 'r w c');
+perm('t3', 'R w c');
+
+try "## u5";
+try "glt info u5 -json; ok";
+$href = from_json(text());
+perm('foo/..*', 'r w c');
+perm('testing', 'R W c');
+perm('t1', 'r w c');
+perm('t2', 'r w c');
+perm('t3', 'r w c');
+
+try "## u6";
+try "glt info u6 -json; ok";
+$href = from_json(text());
+perm('foo/..*', 'r w c');
+perm('testing', 'R W c');
+perm('t1', 'r w c');
+perm('t2', 'r w c');
+perm('t3', 'r w c');
+
+try "## ls-remote foo/one";
+try "glt ls-remote u1 file:///foo/one;   ok";
+
+try "## u1";
+try "glt info u1 -json; ok; !/creator..:/";
+$href = from_json(text());
+perm('foo/..*', 'r w C');
+perm('foo/one', 'R W c');
+test_creator('foo/one', 'u1', 'undef');
+
+try "## u2";
+try "glt info u2 -json; ok; !/creator..:/";
+$href = from_json(text());
+perm('foo/..*', 'r w c');
+perm('foo/one', 'r w c');
+test_creator('foo/one', 'u1', 'undef');
+
+try "## u3";
+try "glt info u3 -json; ok; !/creator..:/";
+$href = from_json(text());
+perm('foo/..*', 'R W c');
+perm('foo/one', 'R W c');
+test_creator('foo/one', 'u1', 'undef');
+
+try("## with -lc now");
+
+try "## u1";
+try "glt info u1 -lc -json; ok";
+$href = from_json(text());
+perm('foo/..*', 'r w C');
+perm('foo/one', 'R W c');
+test_creator('foo/one', 'u1', 1);
+
+try "## u2";
+try "glt info u2 -lc -json; ok";
+$href = from_json(text());
+perm('foo/..*', 'r w c');
+perm('foo/one', 'r w c');
+test_creator('foo/one', 'u1', 'undef');
+
+try "## u3";
+try "glt info u3 -lc -json; ok";
+$href = from_json(text());
+perm('foo/..*', 'R W c');
+perm('foo/one', 'R W c');
+test_creator('foo/one', 'u1', 1);
+
+# ----------------------------------------------------------------------
+
+# test perms given repo and expected perms.  (lowercase r/w/c means NOT
+# expected, uppercase means expected)
+sub perm {
+    my ($repo, $aa) = @_;
+    for my $aa1 (split ' ', $aa) {
+        my $exp = 1;
+        if ($aa1 =~ /[a-z]/) {
+            $exp = 'undef';     # we can't use 0, though I'd like to
+            $aa1 = uc($aa1);
+        }
+        my $perm = $href->{repos}{$repo}{perms}{$aa1} || 'undef';
+        try 'perl $_ = "' . $perm  . '"; /' . $exp . '/';
+    }
+}
+
+# test versions in greeting string
+sub test_gs {
+    my $glu = shift;
+    my $res = ( $href->{GL_USER} eq $glu ? 1 : 'undef' );
+    try 'perl $_ = "' . $res  . '"; /1/';
+    $res = ( $href->{gitolite_version} =~ /^v3.[5-9]/ ? 1 : 'undef' );
+    try 'perl $_ = "' . $res  . '"; /1/';
+    $res = ( $href->{git_version} =~ /^1.[6-9]/ ? 1 : 'undef' );
+    try 'perl $_ = "' . $res  . '"; /1/';
+}
+
+# test creator
+sub test_creator {
+    my ($r, $c, $exp) = @_;
+    my $res = ( ($href->{repos}{$r}{creator} || '') eq $c ? 1 : 'undef' );
+    try 'perl $_ = "' . $res  . '"; /' . $exp . '/';
+}