'info' command, plus lots more changes:

- usage() gets a little smarter; it now knows what function it was called
    from and tries to find a '=for function_name' chunk of data in the script

  - the various list-* functions now work off a dispatcher in Load.pm
  - (...and they all use the new usage() magic to print their helps!)

  - src/gitolite got a lot leaner due to this dispatcher

  - src/gitolite-shell became a lot more easier to read/flow

  - rc acquired '{COMMANDS}', which gitolite-shell now refers to
  - comments in the default rc file changed a bit
  - rc got a new REMOTE_COMMAND_PATT (in place of ADC_CMD_ARGS_PATT)

the rest is perltidy and stuff like that

src/Gitolite/Common.pm

@@ -75,13 +75,17 @@ sub _die {
 }
 
 sub usage {
-    my ($warn, $section) = @_;
+    _warn(shift) if @_;
-    _warn($warn) if $warn;
+    my ( $script, $function ) = ( caller(1) )[ 1, 3 ];
-    $section ||= 'usage';
+    if (not $script) {
-    my $scriptname = ( caller() )[1];
+        $script = ( caller ) [1];
-    my $script     = slurp($scriptname);
+        $function = 'usage';
-    $script =~ /^=for $section(.*?)^=cut/sm;
+    }
-    say2( $1 ? $1 : "...no usage message in $scriptname" );
+    dbg( "u s a g e", $script, $function );
+    $function =~ s/.*:://;
+    my $code = slurp($script);
+    $code =~ /^=for $function(.*?)^=cut/sm;
+    say2( $1 ? $1 : "...no usage message in $script" );
     exit 1;
 }
 
@@ -177,7 +181,6 @@ sub cleanup_conf_line {
     my @phy_repos = ();
 
     sub list_phy_repos {
-        _die "'gitolite list_phy_repos' takes no arguments" if @ARGV;
         trace(3);
 
         # use cached value only if it exists *and* no arg was received (i.e.,

src/Gitolite/Conf.pm

@@ -24,7 +24,7 @@ use warnings;
 
 sub compile {
     trace(3);
-    # XXX assume we're in admin-base/conf
+    _die "'gitolite compile' does not take any arguments" if @_;
 
     _chdir( $rc{GL_ADMIN_BASE} );
     _chdir("conf");

src/Gitolite/Conf/Load.pm

@@ -7,12 +7,7 @@ package Gitolite::Conf::Load;
   load
   access
   vrefs
-
+  lister_dispatch
-  list_groups
-  list_users
-  list_repos
-  list_memberships
-  list_members
 );
 
 use Exporter 'import';
@@ -25,8 +20,6 @@ use warnings;
 
 # ----------------------------------------------------------------------
 
-my $subconf = 'master';
-
 # our variables, because they get loaded by a 'do'
 our $data_version = '';
 our %repos;
@@ -36,6 +29,16 @@ our %configs;
 our %one_config;
 our %split_conf;
 
+my $subconf = 'master';
+
+my %listers = (
+    'list-groups'      => \&list_groups,
+    'list-users'       => \&list_users,
+    'list-repos'       => \&list_repos,
+    'list-memberships' => \&list_memberships,
+    'list-members'     => \&list_members,
+);
+
 # helps maintain the "cache" in both "load_common" and "load_1"
 my $last_repo = '';
 
@@ -200,15 +203,22 @@ sub data_version_mismatch {
 # api functions
 # ----------------------------------------------------------------------
 
-# list all groups
+sub lister_dispatch {
-sub list_groups {
+    my $command = shift;
-    die "
+
+    my $fn = $listers{$command} or _die "unknown gitolite sub-command";
+    return $fn;
+}
+
+=for list_groups
 Usage:  gitolite list-groups
 
   - lists all group names in conf
   - no options, no flags
+=cut
 
-" if @ARGV;
+sub list_groups {
+    usage() if @_;
 
     load_common();
 
@@ -219,18 +229,18 @@ Usage:  gitolite list-groups
     return ( sort_u( \@g ) );
 }
 
-sub list_users {
+=for list_users
-    my $count = 0;
-    my $total = 0;
-
-    die "
 Usage:  gitolite list-users
 
   - lists all users/user groups in conf
   - no options, no flags
   - WARNING: may be slow if you have thousands of repos
+=cut
 
-" if @ARGV;
+sub list_users {
+    usage() if @_;
+    my $count = 0;
+    my $total = 0;
 
     load_common();
 
@@ -242,19 +252,19 @@ Usage:  gitolite list-users
         $count++; print STDERR "$count / $total\r" if not( $count % 100 ) and timer(5);
         push @u, map { keys %{$_} } values %one_repo;
     }
-    print STDERR "\n";
+    print STDERR "\n" if $count >= 100;
     return ( sort_u( \@u ) );
 }
 
-sub list_repos {
+=for list_repos
-
-    die "
 Usage:  gitolite list-repos
 
   - lists all repos/repo groups in conf
   - no options, no flags
+=cut
 
-" if @ARGV;
+sub list_repos {
+    usage() if @_;
 
     load_common();
 
@@ -264,34 +274,34 @@ Usage:  gitolite list-repos
     return ( sort_u( \@r ) );
 }
 
-sub list_memberships {
+=for list_memberships
-
-    die "
 Usage:  gitolite list-memberships <name>
 
   - list all groups a name is a member of
   - takes one user/repo name
+=cut
 
-" if @ARGV and $ARGV[0] eq '-h' or not @ARGV and not @_;
+sub list_memberships {
+    usage() if @_ and $_[0] eq '-h' or not @_;
 
-    my $name = ( @_ ? shift @_ : shift @ARGV );
+    my $name = shift;
 
     load_common();
     my @m = memberships($name);
     return ( sort_u( \@m ) );
 }
 
-sub list_members {
+=for list_members
-
-    die "
 Usage:  gitolite list-members <group name>
 
   - list all members of a group
   - takes one group name
+=cut
 
-" if @ARGV and $ARGV[0] eq '-h' or not @ARGV and not @_;
+sub list_members {
+    usage() if @_ and $_[0] eq '-h' or not @_;
 
-    my $name = ( @_ ? shift @_ : shift @ARGV );
+    my $name = shift;
 
     load_common();
 

src/Gitolite/Conf/Store.pm

@@ -207,8 +207,7 @@ sub store {
 }
 
 sub parse_done {
-    for my $ig (sort keys %ignored)
+    for my $ig ( sort keys %ignored ) {
-    {
         _warn "$ig.conf attempting to set access for " . join( ", ", sort keys %{ $ignored{$ig} } );
     }
 }

src/Gitolite/Rc.pm

@@ -8,7 +8,7 @@ package Gitolite::Rc;
   glrc
   query_rc
 
-  $ADC_CMD_ARGS_PATT
+  $REMOTE_COMMAND_PATT
   $REF_OR_FILENAME_PATT
   $REPONAME_PATT
   $REPOPATT_PATT
@@ -36,7 +36,7 @@ $rc{GL_REPO_BASE}  = "$ENV{HOME}/repositories";
 # variables that should probably never be changed
 # ----------------------------------------------------------------------
 
-$ADC_CMD_ARGS_PATT    = qr(^[0-9a-zA-Z._\@/+:-]*$);
+$REMOTE_COMMAND_PATT  = qr(^[- 0-9a-zA-Z\@\%_=+:,./]*$);
 $REF_OR_FILENAME_PATT = qr(^[0-9a-zA-Z][0-9a-zA-Z._\@/+ :,-]*$);
 $REPONAME_PATT        = qr(^\@?[0-9a-zA-Z][0-9a-zA-Z._\@/+-]*$);
 $REPOPATT_PATT        = qr(^\@?[0-9a-zA-Z[][\\^.$|()[\]*+?{}0-9a-zA-Z._\@/,-]*$);
@@ -101,23 +101,6 @@ sub glrc {
 # implements 'gitolite query-rc'
 # ----------------------------------------------------------------------
 
-=for usage
-
-Usage:  gitolite query-rc -a
-        gitolite query-rc [-n] <list of rc variables>
-
-    -a          print all variables and values
-    -n          do not append a newline
-
-Example:
-
-    gitolite query-rc GL_ADMIN_BASE GL_UMASK
-    # prints "/home/git/.gitolite<tab>0077" or similar
-
-    gitolite query-rc -a
-    # prints all known variables and values, one per line
-=cut
-
 # ----------------------------------------------------------------------
 
 my $all  = 0;
@@ -134,14 +117,34 @@ sub query_rc {
         for my $e ( sort keys %rc ) {
             print "$e=" . ( defined( $rc{$e} ) ? $rc{$e} : 'undef' ) . "\n";
         }
-        return;
+        exit 0;
     }
 
-    print join( "\t", map { $rc{$_} || '' } @vars ) . ($nonl ? '' : "\n") if @vars;
+    my @res = map { $rc{$_} } grep { $rc{$_} } @vars;
+    print join( "\t", @res ) . ( $nonl ? '' : "\n" ) if @res;
+    # shell truth
+    exit 0 if @res;
+    exit 1;
 }
 
 # ----------------------------------------------------------------------
 
+=for args
+Usage:  gitolite query-rc -a
+        gitolite query-rc [-n] <list of rc variables>
+
+    -a          print all variables and values
+    -n          do not append a newline
+
+Example:
+
+    gitolite query-rc GL_ADMIN_BASE UMASK
+    # prints "/home/git/.gitolite<tab>0077" or similar
+
+    gitolite query-rc -a
+    # prints all known variables and values, one per line
+=cut
+
 sub args {
     my $help = 0;
 
@@ -163,30 +166,35 @@ sub args {
 __DATA__
 # configuration variables for gitolite
 
-# PLEASE READ THE DOCUMENTATION BEFORE EDITING OR ASKING QUESTIONS
+# This file is in perl syntax.  But you do NOT need to know perl to edit it --
+# just mind the commas and make sure the brackets and braces stay matched up!
 
-# This file is in perl syntax.
+# (Tip: perl allows a comma after the last item in a list also!)
-
-# However, you do NOT need to know perl to edit it; it should be fairly
-# self-explanatory and easy to maintain.  Just mind the commas (perl is quite
-# happy to have an extra one at the end of the last item in any list, by the
-# way!).  And make sure the brackets and braces stay matched up!
 
 %RC = (
     UMASK                       =>  0077,
     GL_GITCONFIG_KEYS           =>  "",
 
     # comment out or uncomment as needed
+    # these will run in sequence during the conf file parse
     SYNTACTIC_SUGAR             =>
         [
             # 'continuation-lines',
         ],
 
     # comment out or uncomment as needed
+    # these will run in sequence after post-update
     POST_COMPILE                =>
         [
             'ssh-authkeys',
         ],
+
+    # comment out or uncomment as needed
+    # these are available to remote users
+    COMMANDS                    =>
+        {
+            'info'              =>  1,
+        },
 );
 
 # ------------------------------------------------------------------------------

src/Gitolite/Setup.pm

@@ -3,14 +3,15 @@ package Gitolite::Setup;
 # implements 'gitolite setup'
 # ----------------------------------------------------------------------
 
-=for usage
+=for args
 Usage:  gitolite setup [<at least one option>]
 
-
     -a, --admin <name>          admin user name
     -pk --pubkey <file>         pubkey file name
     -f, --fixup-hooks           fixup hooks
 
+Setup (first run only), then compile conf and fixup hooks.
+
 First run:
     -a      required
     -pk     required for ssh mode install

src/Gitolite/Test/Tsh.pm

@@ -259,8 +259,7 @@ sub rc_lines {
             $cmd = shift @cmds;
 
             # is the current command a "testing" command?
-            my $testing_cmd =
+            my $testing_cmd = ( $cmd =~ m(^ok(?:\s+or\s+(.*))?$) or $cmd =~ m(^!ok(?:\s+or\s+(.*))?$) or $cmd =~ m(^/(.*?)/(?:\s+or\s+(.*))?$) or $cmd =~ m(^!/(.*?)/(?:\s+or\s+(.*))?$) );
-              ( $cmd =~ m(^ok(?:\s+or\s+(.*))?$) or $cmd =~ m(^!ok(?:\s+or\s+(.*))?$) or $cmd =~ m(^/(.*?)/(?:\s+or\s+(.*))?$) or $cmd =~ m(^!/(.*?)/(?:\s+or\s+(.*))?$) );
 
             # warn if the previous command failed but rc is not being checked
             if ( $rc and not $testing_cmd ) {

src/VREF/COUNT

@@ -1,4 +1,5 @@
 #!/bin/bash
+# TODO: convert to perl!
 
 # gitolite VREF to count number of changed/new files in a push
 

src/VREF/FILETYPE

@@ -1,4 +1,5 @@
 #!/bin/bash
+# TODO: convert to perl!
 
 # gitolite VREF to find autogenerated files
 

src/commands/info

@@ -0,0 +1,31 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use lib $ENV{GL_BINDIR};
+use Gitolite::Rc;
+use Gitolite::Common;
+use Gitolite::Conf::Load;
+
+=for usage
+Usage:  gitolite info
+
+  - list all repos/repo groups you can access
+  - no options, no flags
+=cut
+
+usage() if @ARGV;
+
+my $user = $ENV{GL_USER} or _die "GL_USER not set";
+my $ref = 'any';
+
+my $fn = lister_dispatch('list-repos');
+
+for ( @{ $fn->() } ) {
+    my $perm = '';
+    for my $aa (qw(R W ^C)) {
+        my $ret = access($_, $user, $aa, $ref);
+        $perm .= ( $ret =~ /DENIED/ ? "  " : " $aa" );
+    }
+    print "$perm\t$_\n" if $perm =~ /\S/;
+}

src/gitolite

@@ -3,7 +3,7 @@
 # all gitolite CLI tools run as sub-commands of this command
 # ----------------------------------------------------------------------
 
-=for usage
+=for args
 Usage:  gitolite [sub-command] [options]
 
 The following subcommands are available; they should all respond to '-h' if
@@ -11,14 +11,16 @@ you want further details on each:
 
     setup                       1st run: initial setup; all runs: hook fixups
     compile                     compile gitolite.conf
+
     query-rc                    get values of rc variables
+    post-compile                run a post-compile command
+
     list-groups                 list all group names in conf
     list-users                  list all users/user groups in conf
     list-repos                  list all repos/repo groups in conf
     list-phy-repos              list all repos actually on disk
     list-memberships            list all groups a name is a member of
     list-members                list all members of a group
-    post-compile                run a post-compile command
 
 Warnings:
   - list-users is disk bound and could take a while on sites with 1000s of repos
@@ -40,66 +42,56 @@ use warnings;
 
 # ----------------------------------------------------------------------
 
+my ( $command, @args ) = @ARGV;
 args();
 
-# ----------------------------------------------------------------------
+# the first two commands need options via @ARGV, as they have their own
-
+# GetOptions calls and older perls don't have 'GetOptionsFromArray'
-sub args {
-    my ( $command, @args ) = @ARGV;
-    usage() if not $command or $command eq '-h';
 
 if ( $command eq 'setup' ) {
     shift @ARGV;
     require Gitolite::Setup;
     Gitolite::Setup->import;
     setup();
-    } elsif ( $command eq 'compile' ) {
+
-        shift @ARGV;
-        _die "'gitolite compile' does not take any arguments" if @ARGV;
-        require Gitolite::Conf;
-        Gitolite::Conf->import;
-        compile();
 } elsif ( $command eq 'query-rc' ) {
     shift @ARGV;
-        query_rc();
+    query_rc();     # doesn't return
-    } elsif ( $command eq 'list-groups' ) {
+
-        shift @ARGV;
+# the rest don't need @ARGV per se
-        require Gitolite::Conf::Load;
+
-        Gitolite::Conf::Load->import;
+} elsif ( $command eq 'compile' ) {
-        print "$_\n" for ( @{ list_groups() } );
+    require Gitolite::Conf;
-    } elsif ( $command eq 'list-users' ) {
+    Gitolite::Conf->import;
-        shift @ARGV;
+    compile(@args);
-        require Gitolite::Conf::Load;
+
-        Gitolite::Conf::Load->import;
-        print "$_\n" for ( @{ list_users() } );
-    } elsif ( $command eq 'list-repos' ) {
-        shift @ARGV;
-        require Gitolite::Conf::Load;
-        Gitolite::Conf::Load->import;
-        print "$_\n" for ( @{ list_repos() } );
-    } elsif ( $command eq 'list-phy-repos' ) {
-        shift @ARGV;
-        _chdir( $rc{GL_REPO_BASE} );
-        print "$_\n" for ( @{ list_phy_repos() } );
-    } elsif ( $command eq 'list-memberships' ) {
-        shift @ARGV;
-        require Gitolite::Conf::Load;
-        Gitolite::Conf::Load->import;
-        print "$_\n" for ( @{ list_memberships() } );
-    } elsif ( $command eq 'list-members' ) {
-        shift @ARGV;
-        require Gitolite::Conf::Load;
-        Gitolite::Conf::Load->import;
-        print "$_\n" for ( @{ list_members() } );
 } elsif ( $command eq 'post-compile' ) {
-        shift @ARGV;
+    post_compile(@args);
-        post_compile();
+
+} elsif ( -x "$rc{GL_BINDIR}/commands/$command" ) {
+    run_command( $command, @args );
+
+} elsif ( $command eq 'list-phy-repos' ) {
+    _chdir( $rc{GL_REPO_BASE} );
+    print "$_\n" for ( @{ list_phy_repos(@args) } );
+
+} elsif ( $command =~ /^list-/ ) {
+    require Gitolite::Conf::Load;
+    Gitolite::Conf::Load->import;
+    my $fn = lister_dispatch($command);
+    print "$_\n" for ( @{ $fn->(@args) } );
+
 } else {
     _die "unknown gitolite sub-command";
 }
+
+sub args {
+    usage() if not $command or $command eq '-h';
 }
 
-=for post-compile
+# ----------------------------------------------------------------------
+
+=for post_compile
 Usage:  gitolite post-compile [-l] [post-compile-scriptname] [script args...]
 
     -l          list currently available post-compile scripts
@@ -109,17 +101,26 @@ the gitolite-admin repo).
 =cut
 
 sub post_compile {
-    usage('', 'post-compile') if (@ARGV and $ARGV[0] eq '-h');
+    usage() if ( not @_ or $_[0] eq '-h' );
 
-    if (@ARGV and $ARGV[0] eq '-l') {
+    run_subdir('post-compile', @_);
-        _chdir("$ENV{GL_BINDIR}/post-compile");
+}
+
+sub run_command {
+    run_subdir('commands', @_);
+}
+
+sub run_subdir {
+    my $subdir = shift;
+    if ( @_ and $_[0] eq '-l' ) {
+        _chdir("$ENV{GL_BINDIR}/$subdir");
         map { say2($_) } grep { -x } glob("*");
         exit 0;
     }
 
-    my $pgm = shift @ARGV;
+    my $pgm      = shift;
-    my $fullpath = "$ENV{GL_BINDIR}/post-compile/$pgm";
+    my $fullpath = "$ENV{GL_BINDIR}/$subdir/$pgm";
     _die "$pgm not found or not executable" if not -x $fullpath;
-    _system($fullpath, @ARGV);
+    _system( $fullpath, @_ );
     exit 0;
 }

src/gitolite-shell

@@ -13,38 +13,89 @@ use Gitolite::Conf::Load;
 
 use strict;
 use warnings;
-print STDERR "TRACE: gsh(", join( ")(", @ARGV ), ")\n";
+
-print STDERR "TRACE: gsh(SOC=$ENV{SSH_ORIGINAL_COMMAND})\n";
+# the main() sub expects ssh-ish things; set them up...
+if ( exists $ENV{G3T_USER} ) {
+    in_local();    # file:// masquerading as ssh:// for easy testing
+} elsif ( exists $ENV{SSH_CONNECTION} ) {
+    in_ssh();
+} elsif ( exists $ENV{REQUEST_URI} ) {
+    in_http();
+} else {
+    _die "who the *heck* are you?";
+}
+
+main();
+
+exit 0;
 
 # ----------------------------------------------------------------------
 
 # XXX lots of stuff from gl-auth-command is missing for now...
 
+sub in_local {
+    print STDERR "TRACE: gsh(", join( ")(", @ARGV ), ")\n";
+    print STDERR "TRACE: gsh(SOC=$ENV{SSH_ORIGINAL_COMMAND})\n";
+}
+
+sub in_http {
+    _die 'http not yet implemented...';
+}
+
+sub in_ssh {
+}
+
+# ----------------------------------------------------------------------
+
+# call this once you are sure arg-1 is the username and SSH_ORIGINAL_COMMAND
+# has been setup (even if it's not actually coming via ssh).
+sub main {
     # set up the user
-my $user = $ENV{GL_USER} = shift;
+    my $user = $ENV{GL_USER} = shift @ARGV;
 
     # set up the repo and the attempted access
-my ( $verb, $repo ) = split_soc();
+    my ( $verb, $repo ) = parse_soc();  # returns only for git commands
     sanity($repo);
     $ENV{GL_REPO} = $repo;
     my $aa = ( $verb =~ 'upload' ? 'R' : 'W' );
 
     # a ref of 'any' signifies that this is a pre-git check, where we don't
-# yet know the ref that will be eventually pushed (and even that won't apply
+    # yet know the ref that will be eventually pushed (and even that won't
-# if it's a read operation).  See the matching code in access() for more.
+    # apply if it's a read operation).  See the matching code in access() for
+    # more information.
     my $ret = access( $repo, $user, $aa, 'any' );
     trace( 1, "access($repo, $user, $aa, 'any') -> $ret" );
     _die $ret if $ret =~ /DENIED/;
 
     $repo = "'$rc{GL_REPO_BASE}/$repo.git'";
     exec( "git", "shell", "-c", "$verb $repo" );
+}
 
 # ----------------------------------------------------------------------
 
-sub split_soc {
+sub parse_soc {
     my $soc = $ENV{SSH_ORIGINAL_COMMAND};
-    return ( $1, $2 ) if $soc =~ m(^(git-(?:upload|receive)-pack) '/?(.*?)(?:\.git)?'$);
+    $soc ||= 'info';
-    _die "unknown command: $soc";
+
+    if ( $soc =~ m(^(git-(?:upload|receive)-pack) '/?(.*?)(?:\.git)?'$) ) {
+        # TODO git archive
+        my($verb, $repo) = ($1, $2);
+        _die "invalid repo name: '$repo'" if $repo !~ $REPONAME_PATT;
+        return ($verb, $repo);
+    }
+
+    # after this we should not return; caller expects us to handle it all here
+    # and exit out
+
+    _die "suspicious characters loitering about '$soc'" if $soc !~ $REMOTE_COMMAND_PATT;
+
+    my @words = split ' ', $soc;
+    if ($rc{COMMANDS}{$words[0]}) {
+        _system("gitolite", @words);
+        exit 0;
+    }
+
+    _die "unknown git/gitolite command: $soc";
 }
 
 sub sanity {

t/glt

@@ -12,7 +12,10 @@ my $user = shift or die "need user";
 my $rc;
 
 $ENV{G3T_USER} = $user;
-if ( $cmd eq 'push' ) {
+if ($cmd eq 'info' ) {
+    $ENV{SSH_ORIGINAL_COMMAND} = $cmd;
+    exec( "$ENV{GL_BINDIR}/../src/gitolite-shell", $user );
+} elsif ( $cmd eq 'push' ) {
     $rc = system( "git", $cmd, "--receive-pack=$ENV{GL_BINDIR}/gitolite-receive-pack", @ARGV );
 } else {
     $rc = system( "git", $cmd, "--upload-pack=$ENV{GL_BINDIR}/gitolite-upload-pack", @ARGV );