'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
This commit is contained in:
Sitaram Chamarty
parent
0aeb0cd5e2
commit
7f8020adc5
|
|
@ -42,8 +42,8 @@ sub trace {
|
|||
my $level = shift; return if $ENV{D} < $level;
|
||||
my $args = ''; $args = join( ", ", @_ ) if @_;
|
||||
my $sub = ( caller 1 )[3] || ''; $sub =~ s/.*://; $sub .= ' ' x ( 32 - length($sub) );
|
||||
say2 "TRACE $level $sub", (@_ ? shift : ());
|
||||
say2("TRACE $level " . (" " x 32), $_)for @_;
|
||||
say2 "TRACE $level $sub", ( @_ ? shift : () );
|
||||
say2( "TRACE $level " . ( " " x 32 ), $_ ) for @_;
|
||||
}
|
||||
|
||||
sub dbg {
|
||||
|
|
@ -75,13 +75,17 @@ sub _die {
|
|||
}
|
||||
|
||||
sub usage {
|
||||
my ($warn, $section) = @_;
|
||||
_warn($warn) if $warn;
|
||||
$section ||= 'usage';
|
||||
my $scriptname = ( caller() )[1];
|
||||
my $script = slurp($scriptname);
|
||||
$script =~ /^=for $section(.*?)^=cut/sm;
|
||||
say2( $1 ? $1 : "...no usage message in $scriptname" );
|
||||
_warn(shift) if @_;
|
||||
my ( $script, $function ) = ( caller(1) )[ 1, 3 ];
|
||||
if (not $script) {
|
||||
$script = ( caller ) [1];
|
||||
$function = 'usage';
|
||||
}
|
||||
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;
|
||||
}
|
||||
|
||||
|
|
@ -154,8 +158,8 @@ sub ln_sf {
|
|||
sub sort_u {
|
||||
my %uniq;
|
||||
my $listref = shift;
|
||||
return [] unless @{ $listref };
|
||||
undef @uniq{ @{ $listref } }; # expect a listref
|
||||
return [] unless @{$listref};
|
||||
undef @uniq{ @{$listref} }; # expect a listref
|
||||
my @sort_u = sort keys %uniq;
|
||||
return \@sort_u;
|
||||
}
|
||||
|
|
@ -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.,
|
||||
|
|
@ -189,7 +192,7 @@ sub cleanup_conf_line {
|
|||
$repo =~ s(\./(.*)\.git$)($1);
|
||||
push @phy_repos, $repo;
|
||||
}
|
||||
return sort_u(\@phy_repos);
|
||||
return sort_u( \@phy_repos );
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -24,12 +24,12 @@ 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");
|
||||
|
||||
parse(sugar('gitolite.conf'));
|
||||
parse( sugar('gitolite.conf') );
|
||||
|
||||
# the order matters; new repos should be created first, to give store a
|
||||
# place to put the individual gl-conf files
|
||||
|
|
@ -39,7 +39,7 @@ sub compile {
|
|||
|
||||
sub parse {
|
||||
my $lines = shift;
|
||||
trace(4, scalar(@$lines) . " lines incoming");
|
||||
trace( 4, scalar(@$lines) . " lines incoming" );
|
||||
|
||||
for my $line (@$lines) {
|
||||
# user or repo groups
|
||||
|
|
|
|||
|
|
@ -7,12 +7,7 @@ package Gitolite::Conf::Load;
|
|||
load
|
||||
access
|
||||
vrefs
|
||||
|
||||
list_groups
|
||||
list_users
|
||||
list_repos
|
||||
list_memberships
|
||||
list_members
|
||||
lister_dispatch
|
||||
);
|
||||
|
||||
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 = '';
|
||||
|
||||
|
|
@ -118,7 +121,7 @@ sub load_1 {
|
|||
my $repo = shift;
|
||||
trace( 4, $repo );
|
||||
|
||||
_chdir( "$rc{GL_REPO_BASE}/$repo.git" );
|
||||
_chdir("$rc{GL_REPO_BASE}/$repo.git");
|
||||
|
||||
if ( $repo eq $last_repo ) {
|
||||
$repos{$repo} = $one_repo{$repo};
|
||||
|
|
@ -149,7 +152,7 @@ sub load_1 {
|
|||
my ( $repo, $user ) = @_;
|
||||
trace( 4, "repo=$repo, user=$user" );
|
||||
|
||||
return @cached if ($lastrepo eq $repo and $lastuser eq $user and @cached);
|
||||
return @cached if ( $lastrepo eq $repo and $lastuser eq $user and @cached );
|
||||
|
||||
my @rules = ();
|
||||
|
||||
|
|
@ -175,7 +178,7 @@ sub load_1 {
|
|||
sub vrefs {
|
||||
my ( $repo, $user ) = @_;
|
||||
# fill the cache if needed
|
||||
rules($repo, $user) unless ($lastrepo eq $repo and $lastuser eq $user and @cached);
|
||||
rules( $repo, $user ) unless ( $lastrepo eq $repo and $lastuser eq $user and @cached );
|
||||
|
||||
my %seen;
|
||||
my @vrefs = grep { /^VREF\// and not $seen{$_}++ } map { $_->[2] } @cached;
|
||||
|
|
@ -200,15 +203,22 @@ sub data_version_mismatch {
|
|||
# api functions
|
||||
# ----------------------------------------------------------------------
|
||||
|
||||
# list all groups
|
||||
sub list_groups {
|
||||
die "
|
||||
sub lister_dispatch {
|
||||
my $command = shift;
|
||||
|
||||
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 {
|
||||
my $count = 0;
|
||||
my $total = 0;
|
||||
|
||||
die "
|
||||
=for list_users
|
||||
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 {
|
||||
|
||||
die "
|
||||
=for list_repos
|
||||
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 {
|
||||
|
||||
die "
|
||||
=for list_memberships
|
||||
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 {
|
||||
|
||||
die "
|
||||
=for list_members
|
||||
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();
|
||||
|
||||
|
|
|
|||
|
|
@ -207,9 +207,8 @@ sub store {
|
|||
}
|
||||
|
||||
sub parse_done {
|
||||
for my $ig (sort keys %ignored)
|
||||
{
|
||||
_warn "$ig.conf attempting to set access for " . join (", ", sort keys %{ $ignored{$ig} });
|
||||
for my $ig ( sort keys %ignored ) {
|
||||
_warn "$ig.conf attempting to set access for " . join( ", ", sort keys %{ $ignored{$ig} } );
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
package SugarBox;
|
||||
|
||||
sub run_sugar_script {
|
||||
my ($ss, $lref) = @_;
|
||||
my ( $ss, $lref ) = @_;
|
||||
do $ss if -x $ss;
|
||||
$lref = sugar_script($lref);
|
||||
return $lref;
|
||||
|
|
@ -35,7 +35,7 @@ sub sugar {
|
|||
# gets a filename, returns a listref
|
||||
|
||||
my @lines = ();
|
||||
explode(shift, 'master', \@lines);
|
||||
explode( shift, 'master', \@lines );
|
||||
|
||||
my $lines;
|
||||
$lines = \@lines;
|
||||
|
|
@ -43,11 +43,11 @@ sub sugar {
|
|||
# run through the sugar stack one by one
|
||||
|
||||
# first, user supplied sugar:
|
||||
if (exists $rc{SYNTACTIC_SUGAR}) {
|
||||
if (ref($rc{SYNTACTIC_SUGAR}) ne 'ARRAY') {
|
||||
if ( exists $rc{SYNTACTIC_SUGAR} ) {
|
||||
if ( ref( $rc{SYNTACTIC_SUGAR} ) ne 'ARRAY' ) {
|
||||
_warn "bad syntax for specifying sugar scripts; see docs";
|
||||
} else {
|
||||
for my $s (@{ $rc{SYNTACTIC_SUGAR} }) {
|
||||
for my $s ( @{ $rc{SYNTACTIC_SUGAR} } ) {
|
||||
|
||||
# perl-ism; apart from keeping the full path separate from the
|
||||
# simple name, this also protects %rc from change by implicit
|
||||
|
|
@ -55,7 +55,7 @@ sub sugar {
|
|||
my $sfp = "$ENV{GL_BINDIR}/syntactic-sugar/$s";
|
||||
|
||||
_warn("skipped sugar script '$s'"), next if not -x $sfp;
|
||||
$lines = SugarBox::run_sugar_script($sfp, $lines);
|
||||
$lines = SugarBox::run_sugar_script( $sfp, $lines );
|
||||
$lines = [ grep /\S/, map { cleanup_conf_line($_) } @$lines ];
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ use warnings;
|
|||
# ----------------------------------------------------------------------
|
||||
|
||||
sub post_update {
|
||||
trace(3, @ARGV);
|
||||
trace( 3, @ARGV );
|
||||
# this is the *real* post_update hook for gitolite
|
||||
|
||||
tsh_try("git ls-tree --name-only master");
|
||||
|
|
@ -32,11 +32,11 @@ sub post_update {
|
|||
_system("$ENV{GL_BINDIR}/gitolite compile");
|
||||
|
||||
# now run optional post-compile features
|
||||
if (exists $rc{POST_COMPILE}) {
|
||||
if (ref($rc{POST_COMPILE}) ne 'ARRAY') {
|
||||
if ( exists $rc{POST_COMPILE} ) {
|
||||
if ( ref( $rc{POST_COMPILE} ) ne 'ARRAY' ) {
|
||||
_warn "bad syntax for specifying post compile scripts; see docs";
|
||||
} else {
|
||||
for my $s (@{ $rc{POST_COMPILE} }) {
|
||||
for my $s ( @{ $rc{POST_COMPILE} } ) {
|
||||
|
||||
# perl-ism; apart from keeping the full path separate from the
|
||||
# simple name, this also protects %rc from change by implicit
|
||||
|
|
@ -44,7 +44,7 @@ sub post_update {
|
|||
my $sfp = "$ENV{GL_BINDIR}/post-compile/$s";
|
||||
|
||||
_warn("skipped post-compile script '$s'"), next if not -x $sfp;
|
||||
_system($sfp, @ARGV); # they better all return with 0 exit codes!
|
||||
_system( $sfp, @ARGV ); # they better all return with 0 exit codes!
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -28,32 +28,32 @@ sub update {
|
|||
trace( 1, "access($ENV{GL_REPO}, $ENV{GL_USER}, $aa, $ref) -> $ret" );
|
||||
_die $ret if $ret =~ /DENIED/;
|
||||
|
||||
check_vrefs($ref, $oldsha, $newsha, $oldtree, $newtree, $aa);
|
||||
check_vrefs( $ref, $oldsha, $newsha, $oldtree, $newtree, $aa );
|
||||
|
||||
exit 0;
|
||||
}
|
||||
|
||||
sub check_vrefs {
|
||||
my($ref, $oldsha, $newsha, $oldtree, $newtree, $aa) = @_;
|
||||
my ( $ref, $oldsha, $newsha, $oldtree, $newtree, $aa ) = @_;
|
||||
my $name_seen = 0;
|
||||
for my $vref ( vrefs($ENV{GL_REPO}, $ENV{GL_USER}) ) {
|
||||
trace(1, "vref=$vref");
|
||||
if ($vref =~ m(^VREF/NAME/)) {
|
||||
for my $vref ( vrefs( $ENV{GL_REPO}, $ENV{GL_USER} ) ) {
|
||||
trace( 1, "vref=$vref" );
|
||||
if ( $vref =~ m(^VREF/NAME/) ) {
|
||||
# this one is special; we process it right here, and only once
|
||||
next if $name_seen++;
|
||||
|
||||
for my $ref ( map { chomp; s(^)(VREF/NAME/); $_; } `git diff --name-only $oldtree $newtree` ) {
|
||||
check_vref($aa, $ref);
|
||||
check_vref( $aa, $ref );
|
||||
}
|
||||
} else {
|
||||
my($dummy, $pgm, @args) = split '/', $vref;
|
||||
my ( $dummy, $pgm, @args ) = split '/', $vref;
|
||||
$pgm = "$ENV{GL_BINDIR}/VREF/$pgm";
|
||||
-x $pgm or die "$vref: helper program missing or unexecutable\n";
|
||||
|
||||
open( my $fh, "-|", $pgm, @_, $vref, @args ) or die "$vref: can't spawn helper program: $!\n";
|
||||
while (<$fh>) {
|
||||
my ( $ref, $deny_message ) = split( ' ', $_, 2 );
|
||||
check_vref($aa, $ref, $deny_message);
|
||||
check_vref( $aa, $ref, $deny_message );
|
||||
}
|
||||
close($fh) or die $!
|
||||
? "Error closing sort pipe: $!"
|
||||
|
|
@ -63,13 +63,13 @@ sub check_vrefs {
|
|||
}
|
||||
|
||||
sub check_vref {
|
||||
my ($aa, $ref, $deny_message) = @_;
|
||||
my ( $aa, $ref, $deny_message ) = @_;
|
||||
|
||||
my $ret = access( $ENV{GL_REPO}, $ENV{GL_USER}, $aa, $ref );
|
||||
trace( 1, "access($ENV{GL_REPO}, $ENV{GL_USER}, $aa, $ref)", "-> $ret" );
|
||||
_die "$ret" . ( $deny_message ? "\n$deny_message" : '' )
|
||||
if $ret =~ /DENIED/ and $ret !~ /by fallthru/;
|
||||
trace( 1, "remember, fallthru is success here!") if $ret =~ /by fallthru/;
|
||||
trace( 1, "remember, fallthru is success here!" ) if $ret =~ /by fallthru/;
|
||||
}
|
||||
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
@ -130,18 +113,38 @@ sub query_rc {
|
|||
|
||||
no strict 'refs';
|
||||
|
||||
if ( $all ) {
|
||||
for my $e (sort keys %rc) {
|
||||
print "$e=" . ( defined($rc{$e}) ? $rc{$e} : 'undef' ) . "\n";
|
||||
if ($all) {
|
||||
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.
|
||||
|
||||
# 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!
|
||||
# (Tip: perl allows a comma after the last item in a list also!)
|
||||
|
||||
%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,
|
||||
},
|
||||
);
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -259,8 +259,7 @@ sub rc_lines {
|
|||
$cmd = shift @cmds;
|
||||
|
||||
# is the current command a "testing" command?
|
||||
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+(.*))?$) );
|
||||
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+(.*))?$) );
|
||||
|
||||
# warn if the previous command failed but rc is not being checked
|
||||
if ( $rc and not $testing_cmd ) {
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
#!/bin/bash
|
||||
# TODO: convert to perl!
|
||||
|
||||
# gitolite VREF to count number of changed/new files in a push
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
#!/bin/bash
|
||||
# TODO: convert to perl!
|
||||
|
||||
# gitolite VREF to find autogenerated files
|
||||
|
||||
|
|
|
|||
31
src/commands/info
Executable file
31
src/commands/info
Executable file
|
|
@ -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/;
|
||||
}
|
||||
105
src/gitolite
105
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' ) {
|
||||
if ( $command eq 'setup' ) {
|
||||
shift @ARGV;
|
||||
require Gitolite::Setup;
|
||||
Gitolite::Setup->import;
|
||||
setup();
|
||||
} elsif ( $command eq 'compile' ) {
|
||||
|
||||
} elsif ( $command eq 'query-rc' ) {
|
||||
shift @ARGV;
|
||||
_die "'gitolite compile' does not take any arguments" if @ARGV;
|
||||
query_rc(); # doesn't return
|
||||
|
||||
# the rest don't need @ARGV per se
|
||||
|
||||
} elsif ( $command eq 'compile' ) {
|
||||
require Gitolite::Conf;
|
||||
Gitolite::Conf->import;
|
||||
compile();
|
||||
} elsif ( $command eq 'query-rc' ) {
|
||||
shift @ARGV;
|
||||
query_rc();
|
||||
} elsif ( $command eq 'list-groups' ) {
|
||||
shift @ARGV;
|
||||
require Gitolite::Conf::Load;
|
||||
Gitolite::Conf::Load->import;
|
||||
print "$_\n" for ( @{ list_groups() } );
|
||||
} elsif ( $command eq 'list-users' ) {
|
||||
shift @ARGV;
|
||||
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;
|
||||
compile(@args);
|
||||
|
||||
} elsif ( $command eq 'post-compile' ) {
|
||||
post_compile(@args);
|
||||
|
||||
} 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() } );
|
||||
} elsif ( $command eq 'list-memberships' ) {
|
||||
shift @ARGV;
|
||||
print "$_\n" for ( @{ list_phy_repos(@args) } );
|
||||
|
||||
} elsif ( $command =~ /^list-/ ) {
|
||||
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();
|
||||
} else {
|
||||
my $fn = lister_dispatch($command);
|
||||
print "$_\n" for ( @{ $fn->(@args) } );
|
||||
|
||||
} else {
|
||||
_die "unknown gitolite sub-command";
|
||||
}
|
||||
}
|
||||
|
||||
=for post-compile
|
||||
sub args {
|
||||
usage() if not $command or $command eq '-h';
|
||||
}
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
|
||||
=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') {
|
||||
_chdir("$ENV{GL_BINDIR}/post-compile");
|
||||
run_subdir('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 $fullpath = "$ENV{GL_BINDIR}/post-compile/$pgm";
|
||||
my $pgm = shift;
|
||||
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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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...
|
||||
|
||||
# set up the user
|
||||
my $user = $ENV{GL_USER} = shift;
|
||||
sub in_local {
|
||||
print STDERR "TRACE: gsh(", join( ")(", @ARGV ), ")\n";
|
||||
print STDERR "TRACE: gsh(SOC=$ENV{SSH_ORIGINAL_COMMAND})\n";
|
||||
}
|
||||
|
||||
# set up the repo and the attempted access
|
||||
my ( $verb, $repo ) = split_soc();
|
||||
sanity($repo);
|
||||
$ENV{GL_REPO} = $repo;
|
||||
my $aa = ( $verb =~ 'upload' ? 'R' : 'W' );
|
||||
sub in_http {
|
||||
_die 'http not yet implemented...';
|
||||
}
|
||||
|
||||
# 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
|
||||
# if it's a read operation). See the matching code in access() for more.
|
||||
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 in_ssh {
|
||||
}
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
|
||||
sub split_soc {
|
||||
# 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 @ARGV;
|
||||
|
||||
# set up the repo and the attempted access
|
||||
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 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 parse_soc {
|
||||
my $soc = $ENV{SSH_ORIGINAL_COMMAND};
|
||||
return ( $1, $2 ) if $soc =~ m(^(git-(?:upload|receive)-pack) '/?(.*?)(?:\.git)?'$);
|
||||
_die "unknown command: $soc";
|
||||
$soc ||= 'info';
|
||||
|
||||
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 {
|
||||
|
|
|
|||
|
|
@ -89,7 +89,7 @@ sub fp {
|
|||
return map { fp_line($_) } grep { !/^#/ and /\S/ } slurp($in);
|
||||
} else {
|
||||
# one or more actual keys
|
||||
return map { fp_line($_) } grep { !/^#/ and /\S/ } ($in, @_);
|
||||
return map { fp_line($_) } grep { !/^#/ and /\S/ } ( $in, @_ );
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ sub sugar_script {
|
|||
my @out = ();
|
||||
my $keep = '';
|
||||
for my $l (@$lines) {
|
||||
if ($l =~ s/\\$//) {
|
||||
if ( $l =~ s/\\$// ) {
|
||||
$keep .= $l;
|
||||
} else {
|
||||
$l = $keep . $l if $keep;
|
||||
|
|
|
|||
5
t/glt
5
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 );
|
||||
|
|
|
|||
Loading…
Reference in a new issue