deac/gitolite
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

very basic, usable, first cut done

Browse source 
- sausage making hidden
  - lots of important features missing
This commit is contained in:
Sitaram Chamarty 2012-03-08 13:30:13 +05:30
parent 5fd06036ed
commit 60e190215e
21 changed files with 2594 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

81
Gitolite/Commands/QueryRc.pm Normal file
View file

@ -0,0 +1,81 @@
package Gitolite::Commands::QueryRc;
# implements 'gitolite query-rc'
# ----------------------------------------------------------------------
=for usage
Usage: gitolite query-rc -a
gitolite query-rc <list of rc variables>
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
# ----------------------------------------------------------------------
@EXPORT = qw(
query_rc
);
use Exporter 'import';
use Getopt::Long;
use lib $ENV{GL_BINDIR};
use Gitolite::Rc;
use Gitolite::Common;
use strict;
use warnings;
# ----------------------------------------------------------------------
my $all = 0;
# ----------------------------------------------------------------------
sub query_rc {
trace( 1, "rc file not found; default should be " . glrc_default_filename() ) if not glrc_filename();
my @vars = args();
no strict 'refs';
if ( $vars[0] eq '-a' ) {
for my $e (@Gitolite::Rc::EXPORT) {
# perl-ism warning: if you don't do this the implicit aliasing
# screws up Rc's EXPORT list
my $v = $e;
# we stop on the first non-$ var
last unless $v =~ s/^\$//;
print "$v=" . ( defined($$v) ? $$v : 'undef' ) . "\n";
}
}
our $GL_BINDIR = $ENV{GL_BINDIR};
print join( "\t", map { $$_ } grep { $$_ } @vars ) . "\n" if @vars;
}
# ----------------------------------------------------------------------
sub args {
my $help = 0;
GetOptions(
'all|a' => \$all,
'help|h' => \$help,
) or usage();
usage("'-a' cannot be combined with other arguments") if $all and @ARGV;
return '-a' if $all;
usage() if not @ARGV or $help;
return @ARGV;
}
1;

161
Gitolite/Commands/Setup.pm Normal file
View file

@ -0,0 +1,161 @@
package Gitolite::Commands::Setup;
# implements 'gitolite setup'
# ----------------------------------------------------------------------
=for usage
Usage: gitolite setup [<at least one option>]
-a, --admin <name> admin user name
-pk --pubkey <file> pubkey file name
-f, --fixup-hooks fixup hooks
First run:
-a required
-pk required for ssh mode install
Later runs:
no options required; but '-f' can be specified for clarity
=cut
# ----------------------------------------------------------------------
@EXPORT = qw(
setup
);
use Exporter 'import';
use Getopt::Long;
use lib $ENV{GL_BINDIR};
use Gitolite::Rc;
use Gitolite::Common;
use Gitolite::Conf::Store;
use strict;
use warnings;
# ----------------------------------------------------------------------
sub setup {
my ( $admin, $pubkey, $argv ) = args();
# first time
if ( first_run() ) {
trace( 1, "..should happen only on first run" );
setup_glrc();
setup_gladmin( $admin, $pubkey, $argv );
}
system("$ENV{GL_BINDIR}/gitolite compile");
hook_repos(); # all of them, just to be sure
}
# ----------------------------------------------------------------------
sub first_run {
# if the rc file could not be found, it's *definitely* a first run!
return not glrc_filename();
}
sub args {
my $admin = '';
my $pubkey = '';
my $fixup = 0;
my $help = 0;
my $argv = join( " ", @ARGV );
GetOptions(
'admin|a=s' => \$admin,
'pubkey|pk=s' => \$pubkey,
'fixup-hooks|f' => \$fixup,
'help|h' => \$help,
) or usage();
usage() if $help;
usage("first run requires '-a'") if first_run() and not($admin);
_warn("not setting up ssh...") if first_run() and $admin and not $pubkey;
_warn("first run, ignoring '-f'...") if first_run() and $fixup;
_warn("not first run, ignoring '-a' / '-pk'...") if not first_run() and ( $admin or $pubkey );
if ($pubkey) {
$pubkey =~ /\.pub$/ or _die "$pubkey name does not end in .pub";
tsh_try("cat $pubkey") or _die "$pubkey not a readable file";
tsh_lines() == 1 or _die "$pubkey must have exactly one line";
tsh_try("ssh-keygen -l -f $pubkey") or _die "$pubkey does not seem to be a valid ssh pubkey file";
}
return ( $admin || '', $pubkey || '', $argv );
}
sub setup_glrc {
trace(1);
_print( glrc_default_filename(), glrc_default_text() );
}
sub setup_gladmin {
my ( $admin, $pubkey, $argv ) = @_;
trace( 1, $admin );
# reminder: 'admin files' are in ~/.gitolite, 'admin repo' is
# $GL_REPO_BASE/gitolite-admin.git
# grab the pubkey content before we chdir() away
my $pubkey_content = '';
if ($pubkey) {
$pubkey_content = slurp($pubkey);
$pubkey =~ s(.*/)(); # basename
}
# set up the admin files in admin-base
_mkdir($GL_ADMIN_BASE);
_chdir($GL_ADMIN_BASE);
_mkdir("conf");
my $conf;
{
local $/ = undef;
$conf = <DATA>;
}
$conf =~ s/%ADMIN/$admin/g;
_print( "conf/gitolite.conf", $conf );
if ($pubkey) {
_mkdir("keydir");
_print( "keydir/$pubkey", $pubkey_content );
}
# set up the admin repo in repo-base
_chdir();
_mkdir($GL_REPO_BASE);
_chdir($GL_REPO_BASE);
new_repo("gitolite-admin");
# commit the admin files to the admin repo
$ENV{GIT_WORK_TREE} = $GL_ADMIN_BASE;
_chdir("$GL_REPO_BASE/gitolite-admin.git");
system("git add conf/gitolite.conf");
system("git add keydir") if $pubkey;
tsh_try("git config --get user.email") or tsh_run( "git config user.email $ENV{USER}\@" . `hostname` );
tsh_try("git config --get user.name") or tsh_run( "git config user.name '$ENV{USER} on '" . `hostname` );
tsh_try("git diff --cached --quiet")
or tsh_try("git commit -am 'gl-setup $argv'")
or die "setup failed to commit to the admin repo";
delete $ENV{GIT_WORK_TREE};
}
1;
__DATA__
repo gitolite-admin
RW+ = %ADMIN
repo testing
RW+ = @all

175
Gitolite/Common.pm Normal file
View file

@ -0,0 +1,175 @@
package Gitolite::Common;
# common (non-gitolite-specific) functions
# ----------------------------------------------------------------------
#<<<
@EXPORT = qw(
print2 dbg _mkdir _open ln_sf tsh_rc sort_u
say _warn _chdir _print tsh_text
say2 _die slurp tsh_lines
trace tsh_try
usage tsh_run
);
#>>>
use Exporter 'import';
use File::Path qw(mkpath);
use Carp qw(carp cluck croak confess);
use strict;
use warnings;
# ----------------------------------------------------------------------
sub print2 {
local $/ = "\n";
print STDERR @_;
}
sub say {
local $/ = "\n";
print @_, "\n";
}
sub say2 {
local $/ = "\n";
print STDERR @_, "\n";
}
sub trace {
return unless defined( $ENV{D} );
my $level = shift;
my $args = ''; $args = join( ", ", @_ ) if @_;
my $sub = ( caller 1 )[3] || ''; $sub =~ s/.*://; $sub .= ' ' x ( 32 - length($sub) );
say2 "TRACE $level $sub", $args if $ENV{D} >= $level;
}
sub dbg {
use Data::Dumper;
return unless defined( $ENV{D} );
for my $i (@_) {
print STDERR "DBG: " . Dumper($i);
}
}
sub _warn {
if ( $ENV{D} and $ENV{D} >= 3 ) {
cluck "WARNING: ", @_, "\n";
} elsif ( defined( $ENV{D} ) ) {
carp "WARNING: ", @_, "\n";
} else {
warn "WARNING: ", @_, "\n";
}
}
sub _die {
if ( $ENV{D} and $ENV{D} >= 3 ) {
confess "FATAL: " . join( ",", @_ ) . "\n" if defined( $ENV{D} );
} elsif ( defined( $ENV{D} ) ) {
croak "FATAL: " . join( ",", @_ ) . "\n";
} else {
die "FATAL: " . join( ",", @_ ) . "\n";
}
}
sub usage {
_warn(shift) if @_;
my $scriptname = ( caller() )[1];
my $script = slurp($scriptname);
$script =~ /^=for usage(.*?)^=cut/sm;
say2( $1 ? $1 : "...no usage message in $scriptname" );
exit 1;
}
sub _mkdir {
# it's not an error if the directory exists, but it is an error if it
# doesn't exist and we can't create it
my $dir = shift;
my $perm = shift; # optional
return if -d $dir;
mkpath($dir);
chmod $perm, $dir if $perm;
return 1;
}
sub _chdir {
chdir( $_[0] || $ENV{HOME} ) or _die "chdir $_[0] failed: $!\n";
}
sub _open {
open( my $fh, $_[0], $_[1] ) or _die "open $_[1] failed: $!\n";
return $fh;
}
sub _print {
my ( $file, @text ) = @_;
my $fh = _open( ">", "$file.$$" );
print $fh @text;
close($fh) or _die "close $file failed: $! at ", (caller)[1], " line ", (caller)[2], "\n";
my $oldmode = ( ( stat $file )[2] );
rename "$file.$$", $file;
chmod $oldmode, $file if $oldmode;
}
sub slurp {
local $/ = undef;
my $fh = _open( "<", $_[0] );
return <$fh>;
}
sub dos2unix {
# WARNING: when calling this, make sure you supply a list context
s/\r\n/\n/g for @_;
return @_;
}
sub ln_sf {
trace( 4, @_ );
my ( $srcdir, $glob, $dstdir ) = @_;
for my $hook ( glob("$srcdir/$glob") ) {
$hook =~ s/$srcdir\///;
unlink "$dstdir/$hook";
symlink "$srcdir/$hook", "$dstdir/$hook" or croak "could not symlink $srcdir/$hook to $dstdir\n";
}
}
sub sort_u {
my %uniq;
my $listref = shift;
return [] unless @{ $listref };
undef @uniq{ @{ $listref } }; # expect a listref
my @sort_u = sort keys %uniq;
return \@sort_u;
}
# ----------------------------------------------------------------------
# bare-minimum subset of 'Tsh' (see github.com/sitaramc/tsh)
{
my ( $rc, $text );
sub tsh_rc { return $rc || 0; }
sub tsh_text { return $text || ''; }
sub tsh_lines { return split /\n/, $text; }
sub tsh_try {
my $cmd = shift; die "try: expects only one argument" if @_;
$text = `( $cmd ) 2>&1; echo -n RC=\$?`;
if ( $text =~ s/RC=(\d+)$// ) {
$rc = $1;
trace( 4, $text );
return ( not $rc );
}
die "couldnt find RC= in result; this should not happen:\n$text\n\n...\n";
}
sub tsh_run {
open( my $fh, "-|", @_ ) or die "popen failed: $!";
local $/ = undef; $text = <$fh>;
close $fh; warn "pclose failed: $!" if $!;
$rc = ( $? >> 8 );
trace( 4, $text );
return $text;
}
}
1;

183
Gitolite/Conf.pm Normal file
View file

@ -0,0 +1,183 @@
package Gitolite::Conf;
# explode/parse a conf file
# ----------------------------------------------------------------------
@EXPORT = qw(
compile
explode
parse
);
use Exporter 'import';
use Getopt::Long;
use lib $ENV{GL_BINDIR};
use Gitolite::Common;
use Gitolite::Rc;
use Gitolite::Conf::Sugar;
use Gitolite::Conf::Store;
use strict;
use warnings;
# ----------------------------------------------------------------------
# 'seen' for include/subconf files
my %included = ();
# 'seen' for group names on LHS
my %prefixed_groupname = ();
# ----------------------------------------------------------------------
sub compile {
trace(3);
# XXX assume we're in admin-base/conf
_chdir($GL_ADMIN_BASE);
_chdir("conf");
explode( 'gitolite.conf', 'master', \&parse );
# the order matters; new repos should be created first, to give store a
# place to put the individual gl-conf files
new_repos();
store();
}
sub explode {
trace( 4, @_ );
my ( $file, $subconf, $parser ) = @_;
# $parser is a ref to a callback; if not supplied we just print
$parser ||= sub { print shift, "\n"; };
# seed the 'seen' list if it's empty
$included{ device_inode("conf/gitolite.conf") }++ unless %included;
my $fh = _open( "<", $file );
my @fh = <$fh>;
my @lines = macro_expand( "# BEGIN $file\n", @fh, "# END $file\n" );
my $line;
while (@lines) {
$line = shift @lines;
$line = cleanup_conf_line($line);
next unless $line =~ /\S/;
$line = prefix_groupnames( $line, $subconf ) if $subconf ne 'master';
if ( $line =~ /^(include|subconf) "(.+)"$/ or $line =~ /^(include|subconf) '(.+)'$/ ) {
incsub( $1, $2, $subconf, $parser );
} else {
# normal line, send it to the callback function
$parser->($line);
}
}
}
sub parse {
trace( 4, @_ );
my $line = shift;
# user or repo groups
if ( $line =~ /^(@\S+) = (.*)/ ) {
add_to_group( $1, split( ' ', $2 ) );
} elsif ( $line =~ /^repo (.*)/ ) {
set_repolist( split( ' ', $1 ) );
} elsif ( $line =~ /^(-|C|R|RW\+?(?:C?D?|D?C?)M?) (.* )?= (.+)/ ) {
my $perm = $1;
my @refs = parse_refs( $2 || '' );
my @users = parse_users($3);
# XXX what do we do? s/\bCREAT[EO]R\b/~\$creator/g for @users;
for my $ref (@refs) {
for my $user (@users) {
add_rule( $perm, $ref, $user );
}
}
} elsif ( $line =~ /^config (.+) = ?(.*)/ ) {
my ( $key, $value ) = ( $1, $2 );
my @validkeys = split( ' ', ( $GL_GITCONFIG_KEYS || '' ) );
push @validkeys, "gitolite-options\\..*";
my @matched = grep { $key =~ /^$_$/ } @validkeys;
# XXX move this also to add_config: _die "git config $key not allowed\ncheck GL_GITCONFIG_KEYS in the rc file for how to allow it" if (@matched < 1);
# XXX both $key and $value must satisfy a liberal but secure pattern
add_config( 1, $key, $value );
} elsif ( $line =~ /^subconf (\S+)$/ ) {
set_subconf($1);
} else {
_warn "?? $line";
}
}
# ----------------------------------------------------------------------
sub incsub {
my $is_subconf = ( +shift eq 'subconf' );
my ( $include_glob, $subconf, $parser ) = @_;
_die "subconf $subconf attempting to run 'subconf'\n" if $is_subconf and $subconf ne 'master';
# XXX move this to Macros... substitute HOSTNAME word if GL_HOSTNAME defined, otherwise leave as is
# $include_glob =~ s/\bHOSTNAME\b/$GL_HOSTNAME/ if $GL_HOSTNAME;
# XXX g2 diff: include glob is *implicitly* from $GL_ADMIN_BASE/conf, not *explicitly*
# for my $file (glob($include_glob =~ m(^/) ? $include_glob : "$GL_ADMIN_BASE/conf/$include_glob")) {
trace( 3, $is_subconf, $include_glob );
for my $file ( glob($include_glob) ) {
_warn("included file not found: '$file'"), next unless -f $file;
_die "invalid include/subconf filename $file" unless $file =~ m(([^/]+).conf$);
my $basename = $1;
next if already_included($file);
if ($is_subconf) {
$parser->("subconf $basename");
explode( $file, $basename, $parser );
$parser->("subconf $subconf");
# XXX g2 delegaton compat: deal with this: $subconf_seen++;
} else {
explode( $file, $subconf, $parser );
}
}
}
sub prefix_groupnames {
my ( $line, $subconf ) = @_;
my $lhs = '';
# save 'foo' if it's an '@foo = list' line
$lhs = $1 if $line =~ /^@(\S+) = /;
# prefix all @groups in the line
$line =~ s/(^| )(@\S+)(?= |$)/ $1 . ($prefixed_groupname{$subconf}{$2} || $2) /ge;
# now prefix the LHS and store it if needed
if ($lhs) {
$line =~ s/^@\S+ = /"\@$subconf.$lhs = "/e;
trace( 3, "prefixed_groupname.$subconf.\@$lhs = \@$subconf.$lhs" );
}
return $line;
}
sub already_included {
my $file = shift;
my $file_id = device_inode($file);
return 0 unless $included{$file_id}++;
_warn("$file already included");
trace( 3, "$file already included" );
return 1;
}
sub device_inode {
my $file = shift;
trace( 3, $file, ( stat $file )[ 0, 1 ] );
return join( "/", ( stat $file )[ 0, 1 ] );
}
1;

169
Gitolite/Conf/Load.pm Normal file
View file

@ -0,0 +1,169 @@
package Gitolite::Conf::Load;
# load conf data from stored files
# ----------------------------------------------------------------------
@EXPORT = qw(
load
access
);
use Exporter 'import';
use lib $ENV{GL_BINDIR};
use Gitolite::Common;
use Gitolite::Rc;
use strict;
use warnings;
# ----------------------------------------------------------------------
my $subconf = 'master';
# our variables, because they get loaded by a 'do'
our $data_version = '';
our %repos;
our %one_repo;
our %groups;
our %configs;
our %one_config;
our %split_conf;
# helps maintain the "cache" in both "load_common" and "load_1"
my $last_repo = '';
# ----------------------------------------------------------------------
{
my $loaded_repo = '';
sub load {
my $repo = shift or _die "load() needs a reponame";
trace( 4, "$repo" );
if ( $repo ne $loaded_repo ) {
trace( 3, "loading $repo..." );
_chdir("$GL_ADMIN_BASE"); load_common();
_chdir("$GL_REPO_BASE"); load_1($repo);
$loaded_repo = $repo;
}
}
}
sub access {
my ( $repo, $user, $aa, $ref ) = @_;
trace( 3, "repo=$repo, user=$user, aa=$aa, ref=$ref" );
load($repo);
my @rules = rules( $repo, $user );
trace( 3, scalar(@rules) . " rules found" );
for my $r (@rules) {
my $perm = $r->[1];
my $refex = $r->[2];
trace( 4, "perm=$perm, refex=$refex" );
# skip 'deny' rules if the ref is not (yet) known
next if $perm eq '-' and $ref eq 'unknown';
# rule matches if ref matches or ref is unknown (see gitolite-shell)
next unless $ref =~ /^$refex/ or $ref eq 'unknown';
trace( 3, "DENIED by $refex" ) if $perm eq '-';
return "DENIED: $aa access to $repo by $user (rule: $refex)" if $perm eq '-';
# $perm can be RW\+?(C|D|CD|DC)?M?. $aa can be W, +, C or D, or
# any of these followed by "M".
( my $aaq = $aa ) =~ s/\+/\\+/;
$aaq =~ s/M/.*M/;
# as far as *this* ref is concerned we're ok
return $refex if ( $perm =~ /$aaq/ );
}
trace( 3, "DENIED by fallthru" );
return "DENIED: $aa access to $repo by $user (fallthru)";
}
# ----------------------------------------------------------------------
sub load_common {
# we take an unusual approach to caching this function!
# (requires that first call to load_common is before first call to load_1)
if ( $last_repo and $split_conf{$last_repo} ) {
delete $repos{$last_repo};
delete $configs{$last_repo};
return;
}
trace(4);
my $cc = "conf/gitolite.conf-compiled.pm";
_die "parse $cc failed: " . ( $! or $@ ) unless do $cc;
if ( data_version_mismatch() ) {
system("gitolite setup");
_die "parse $cc failed: " . ( $! or $@ ) unless do $cc;
_die "data version update failed; this is serious" if data_version_mismatch();
}
}
sub load_1 {
my $repo = shift;
trace( 4, $repo );
if ( $repo eq $last_repo ) {
$repos{$repo} = $one_repo{$repo};
$configs{$repo} = $one_config{$repo} if $one_config{$repo};
return;
}
if ( -f "$repo.git/gl-conf" ) {
_die "split conf not set, gl-conf present for $repo" if not $split_conf{$repo};
my $cc = "$repo.git/gl-conf";
_die "parse $cc failed: " . ( $! or $@ ) unless do $cc;
$last_repo = $repo;
$repos{$repo} = $one_repo{$repo};
$configs{$repo} = $one_config{$repo} if $one_config{$repo};
} else {
_die "split conf set, gl-conf not present for $repo" if $split_conf{$repo};
}
}
sub rules {
my ( $repo, $user ) = @_;
trace( 4, "repo=$repo, user=$user" );
my @rules = ();
my @repos = memberships($repo);
my @users = memberships($user);
trace( 4, "memberships: " . scalar(@repos) . " repos and " . scalar(@users) . " users found" );
for my $r (@repos) {
for my $u (@users) {
push @rules, @{ $repos{$r}{$u} } if exists $repos{$r}{$u};
}
}
# dbg("before sorting rules:", \@rules);
@rules = sort { $a->[0] <=> $b->[0] } @rules;
# dbg("after sorting rules:", \@rules);
return @rules;
}
sub memberships {
my $item = shift;
my @ret = ( $item, '@all' );
push @ret, @{ $groups{$item} } if $groups{$item};
return @ret;
}
sub data_version_mismatch {
return $data_version ne $current_data_version;
}
1;

356
Gitolite/Conf/Store.pm Normal file
View file

@ -0,0 +1,356 @@
package Gitolite::Conf::Store;
# receive parsed conf data and store it
# ----------------------------------------------------------------------
@EXPORT = qw(
add_to_group
expand_list
set_repolist
parse_refs
parse_users
add_rule
set_subconf
new_repos
new_repo
hook_repos
store
);
use Exporter 'import';
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Sortkeys = 1;
use lib $ENV{GL_BINDIR};
use Gitolite::Common;
use Gitolite::Rc;
use Gitolite::Hooks::Update;
use Gitolite::Hooks::PostUpdate;
use strict;
use warnings;
# ----------------------------------------------------------------------
my %repos;
my %groups;
my %configs;
my %split_conf;
my @repolist; # current repo list; reset on each 'repo ...' line
my $subconf = 'master';
my $ruleseq = 0;
my %ignored;
# XXX you still have to "warn" if this has any entries
# ----------------------------------------------------------------------
sub add_to_group {
my ( $lhs, @rhs ) = @_;
_die "bad group '$lhs'" unless $lhs =~ $REPONAME_PATT;
# store the group association, but overload it to keep track of when
# the group was *first* created by using $subconf as the *value*
do { $groups{$lhs}{$_} ||= $subconf }
for ( expand_list(@rhs) );
# create the group hash even if empty
$groups{$lhs} = {} unless $groups{$lhs};
}
sub expand_list {
my @list = @_;
my @new_list = ();
for my $item (@list) {
if ( $item =~ /^@/ and $item ne '@all' ) # nested group
{
_die "undefined group $item" unless $groups{$item};
# add those names to the list
push @new_list, sort keys %{ $groups{$item} };
} else {
push @new_list, $item;
}
}
return @new_list;
}
sub set_repolist {
@repolist = @_;
# ...sanity checks
for (@repolist) {
_warn "explicit '.git' extension ignored for $_.git" if s/\.git$//;
_die "bad reponame '$_'" if $_ !~ $REPOPATT_PATT;
}
# XXX -- how do we deal with this? s/\bCREAT[EO]R\b/\$creator/g for @{ $repos_p };
}
sub parse_refs {
my $refs = shift;
my @refs; @refs = split( ' ', $refs ) if $refs;
@refs = expand_list(@refs);
# if no ref is given, this PERM applies to all refs
@refs = qw(refs/.*) unless @refs;
# fully qualify refs that dont start with "refs/" or "NAME/" or "VREF/";
# prefix them with "refs/heads/"
@refs = map { m(^(refs|NAME|VREF)/) or s(^)(refs/heads/); $_ } @refs;
# XXX what do we do? @refs = map { s(/USER/)(/\$gl_user/); $_ } @refs;
return @refs;
}
sub parse_users {
my $users = shift;
my @users = split ' ', $users;
do { _die "bad username '$_'" unless $_ =~ $USERNAME_PATT }
for @users;
return @users;
}
sub add_rule {
my ( $perm, $ref, $user ) = @_;
$ruleseq++;
for my $repo (@repolist) {
if ( check_subconf_repo_disallowed( $subconf, $repo ) ) {
my $repo = $repo;
$repo =~ s/^\@$subconf\./locally modified \@/;
$ignored{$subconf}{$repo} = 1;
next;
}
push @{ $repos{$repo}{$user} }, [ $ruleseq, $perm, $ref ];
# XXX g2 diff: we're not doing a lint check for usernames versus pubkeys;
# maybe we can add that later
# XXX to do: C/R/W, then CREATE_IS_C, etc
# XXX to do: also NAME_LIMITS
# XXX and hacks like $creator -> "$creatror - wild"
# XXX consider if you want to use rurp_seen; initially no
}
}
sub set_subconf {
$subconf = shift;
trace( 1, $subconf );
}
sub new_repos {
trace(3);
_chdir($GL_REPO_BASE);
# normal repos
my @repos = grep { $_ =~ $REPONAME_PATT and not /^@/ } sort keys %repos;
# add in members of repo groups
map { push @repos, keys %{ $groups{$_} } } grep { /^@/ } keys %repos;
for my $repo ( @{ sort_u(\@repos) } ) {
next unless $repo =~ $REPONAME_PATT; # skip repo patterns
next if $repo =~ m(^\@|EXTCMD/); # skip groups and fake repos
# XXX how do we deal with GL_NO_CREATE_REPOS?
new_repo($repo) if not -d "$repo.git";
}
}
sub new_repo {
my $repo = shift;
trace( 4, $repo );
# XXX ignoring UMASK for now
_mkdir("$repo.git");
_chdir("$repo.git");
system("git init --bare >&2");
_chdir($GL_REPO_BASE);
hook_1($repo);
# XXX ignoring creator for now
# XXX ignoring gl-post-init for now
}
sub hook_repos {
trace(3);
# all repos, all hooks
_chdir($GL_REPO_BASE);
# XXX g2 diff: we now don't care if it's a symlink -- it's upto the admin
# on the server to make sure things are kosher
for my $repo (`find . -name "*.git" -prune`) {
chomp($repo);
$repo =~ s/\.git$//;
hook_1($repo);
}
}
sub store {
trace(3);
# first write out the ones for the physical repos
my @phy_repos = list_physical_repos(1);
_chdir($GL_REPO_BASE);
for my $repo (@phy_repos) {
store_1($repo);
}
_chdir($GL_ADMIN_BASE);
store_common();
}
# ----------------------------------------------------------------------
sub check_subconf_repo_disallowed {
# trying to set access for $repo (='foo')...
my ( $subconf, $repo ) = @_;
# processing the master config, not a subconf
return 0 if $subconf eq 'master';
# subconf is also called 'foo' (you're allowed to have a
# subconf that is only concerned with one repo)
return 0 if $subconf eq $repo;
# same thing in big-config-land; foo is just @foo now
return 0 if ( "\@$subconf" eq $repo );
my @matched = grep { $repo =~ /^$_$/ }
grep { $groups{"\@$subconf"}{$_} eq 'master' }
sort keys %{ $groups{"\@$subconf"} };
return 0 if @matched > 0;
trace( 3, "disallowed: $subconf for $repo" );
return 1;
}
{
my @phy_repos = ();
sub list_physical_repos {
trace(3);
_chdir($GL_REPO_BASE);
# use cached value only if it exists *and* no arg was received (i.e.,
# receiving *any* arg invalidates cache)
return @phy_repos if ( @phy_repos and not @_ );
for my $repo (`find . -name "*.git" -prune`) {
chomp($repo);
$repo =~ s(\./(.*)\.git$)($1);
push @phy_repos, $repo;
}
return @phy_repos;
}
}
sub store_1 {
# warning: writes and *deletes* it from %repos and %configs
my ($repo) = shift;
trace( 4, $repo );
return unless $repos{$repo} and -d "$repo.git";
my ( %one_repo, %one_config );
open( my $compiled_fh, ">", "$repo.git/gl-conf" ) or return;
$one_repo{$repo} = $repos{$repo};
delete $repos{$repo};
my $dumped_data = Data::Dumper->Dump( [ \%one_repo ], [qw(*one_repo)] );
if ( $configs{$repo} ) {
$one_config{$repo} = $configs{$repo};
delete $configs{$repo};
$dumped_data .= Data::Dumper->Dump( [ \%one_config ], [qw(*one_config)] );
}
# XXX deal with this better now
# $dumped_data =~ s/'(?=[^']*\$(?:creator|gl_user))~?(.*?)'/"$1"/g;
print $compiled_fh $dumped_data;
close $compiled_fh;
$split_conf{$repo} = 1;
}
sub store_common {
trace(4);
my $cc = "conf/gitolite.conf-compiled.pm";
my $compiled_fh = _open( ">", "$cc.new" );
my $data_version = $current_data_version;
trace( 1, "data_version = $data_version" );
print $compiled_fh Data::Dumper->Dump( [$data_version], [qw(*data_version)] );
my $dumped_data = Data::Dumper->Dump( [ \%repos ], [qw(*repos)] );
$dumped_data .= Data::Dumper->Dump( [ \%configs ], [qw(*configs)] ) if %configs;
# XXX and again...
# XXX $dumped_data =~ s/'(?=[^']*\$(?:creator|gl_user))~?(.*?)'/"$1"/g;
print $compiled_fh $dumped_data;
if (%groups) {
my %groups = %{ inside_out( \%groups ) };
$dumped_data = Data::Dumper->Dump( [ \%groups ], [qw(*groups)] );
# XXX $dumped_data =~ s/\bCREAT[EO]R\b/\$creator/g;
# XXX $dumped_data =~ s/'(?=[^']*\$(?:creator|gl_user))~?(.*?)'/"$1"/g;
print $compiled_fh $dumped_data;
}
print $compiled_fh Data::Dumper->Dump( [ \%split_conf ], [qw(*split_conf)] ) if %split_conf;
close $compiled_fh or _die "close compiled-conf failed: $!\n";
rename "$cc.new", $cc;
}
{
my $hook_reset = 0;
sub hook_1 {
my $repo = shift;
trace( 4, $repo );
# reset the gitolite supplied hooks, in case someone fiddled with
# them, but only once per run
if ( not $hook_reset ) {
_mkdir("$GL_ADMIN_BASE/hooks/common");
_mkdir("$GL_ADMIN_BASE/hooks/gitolite-admin");
_print( "$GL_ADMIN_BASE/hooks/common/update", update_hook() );
_print( "$GL_ADMIN_BASE/hooks/gitolite-admin/post-update", post_update_hook() );
chmod 0755, "$GL_ADMIN_BASE/hooks/common/update";
chmod 0755, "$GL_ADMIN_BASE/hooks/gitolite-admin/post-update";
$hook_reset++;
}
# propagate user hooks
ln_sf( "$GL_ADMIN_BASE/hooks/common", "*", "$repo.git/hooks" );
# propagate admin hook
ln_sf( "$GL_ADMIN_BASE/hooks/gitolite-admin", "*", "$repo.git/hooks" ) if $repo eq 'gitolite-admin';
# g2 diff: no "site-wide" hooks (the stuff in between gitolite hooks
# and user hooks) anymore. I don't think anyone used them anyway...
}
}
sub inside_out {
my $href = shift;
# input conf: @aa = bb cc <newline> @bb = @aa dd
my %ret = ();
while ( my ( $k, $v ) = each( %{$href} ) ) {
# $k is '@aa', $v is a href
for my $k2 ( keys %{$v} ) {
# $k2 is bb, then cc
push @{ $ret{$k2} }, $k;
}
}
return \%ret;
# %groups = ( 'bb' => [ '@bb', '@aa' ], 'cc' => [ '@bb', '@aa' ], 'dd' => [ '@bb' ]);
}
1;

82
Gitolite/Conf/Sugar.pm Normal file
View file

@ -0,0 +1,82 @@
package Gitolite::Conf::Sugar;
# syntactic sugar for the conf file, including site-local macros
# ----------------------------------------------------------------------
@EXPORT = qw(
macro_expand
cleanup_conf_line
);
use Exporter 'import';
use lib $ENV{GL_BINDIR};
use Gitolite::Common;
use Gitolite::Rc;
use strict;
use warnings;
# ----------------------------------------------------------------------
sub macro_expand {
# site-local macros, if any, then gitolite internal macros, to munge the
# input conf line if needed
my @lines = @_;
# TODO: user macros, how to allow the user to specify them?
# cheat, to keep *our* regexes simple :)
# XXX but this also kills the special '# BEGIN filename' and '# END
# filename' lines that explode() surrounds the actual data with when it
# called macro_expand(). Right now we don't need it, but...
@lines = grep /\S/, map { cleanup_conf_line($_) } @lines;
@lines = owner_desc(@lines);
return @lines;
}
sub cleanup_conf_line {
my $line = shift;
# kill comments, but take care of "#" inside *simple* strings
$line =~ s/^((".*?"|[^#"])*)#.*/$1/;
# normalise whitespace; keeps later regexes very simple
$line =~ s/=/ = /;
$line =~ s/\s+/ /g;
$line =~ s/^ //;
$line =~ s/ $//;
return $line;
}
sub owner_desc {
my @lines = @_;
my @ret;
for my $line (@lines) {
# reponame = "some description string"
# reponame "owner name" = "some description string"
if ( $line =~ /^(\S+)(?: "(.*?)")? = "(.*)"$/ ) {
my ( $repo, $owner, $desc ) = ( $1, $2, $3 );
# XXX these two checks should go into add_config
# _die "bad repo name '$repo'" unless $repo =~ $REPONAME_PATT;
# _die "$fragment attempting to set description for $repo"
# if check_fragment_repo_disallowed( $fragment, $repo );
push @ret, "config gitolite-options.repo-desc = $desc";
push @ret, "config gitolite-options.repo-owner = $owner" if $owner;
} elsif ( $line =~ /^desc = (\S.*)/ ) {
push @ret, "config gitolite-options.repo-desc = $1";
} elsif ( $line =~ /^owner = (\S.*)/ ) {
my ( $repo, $owner, $desc ) = ( $1, $2, $3 );
push @ret, "config gitolite-options.repo-owner = $1";
} else {
push @ret, $line;
}
}
return @ret;
}
1;

69
Gitolite/Hooks/PostUpdate.pm Normal file
View file

@ -0,0 +1,69 @@
package Gitolite::Hooks::PostUpdate;
# everything to do with the post-update hook
# ----------------------------------------------------------------------
@EXPORT = qw(
post_update
post_update_hook
);
use Exporter 'import';
use lib $ENV{GL_BINDIR};
use Gitolite::Rc;
use Gitolite::Common;
use strict;
use warnings;
# ----------------------------------------------------------------------
sub post_update {
trace(3);
# this is the *real* post_update hook for gitolite
tsh_try("git ls-tree --name-only master");
_die "no files/dirs called 'hooks' or 'logs' are allowed" if tsh_text() =~ /^(hooks|logs)$/;
{
local $ENV{GIT_WORK_TREE} = $GL_ADMIN_BASE;
tsh_try("git checkout -f --quiet master");
}
system("$ENV{GL_BINDIR}/gitolite compile");
exit 0;
}
{
my $text = '';
sub post_update_hook {
trace(1);
if ( not $text ) {
local $/ = undef;
$text = <DATA>;
}
return $text;
}
}
1;
__DATA__
#!/usr/bin/perl
use strict;
use warnings;
BEGIN {
die "GL_BINDIR not set; aborting\n" unless $ENV{GL_BINDIR};
}
use lib $ENV{GL_BINDIR};
use Gitolite::Hooks::PostUpdate;
# gitolite post-update hook (only for the admin repo)
# ----------------------------------------------------------------------
post_update(@ARGV); # is not expected to return
exit 1; # so if it does, something is wrong

114
Gitolite/Hooks/Update.pm Normal file
View file

@ -0,0 +1,114 @@
package Gitolite::Hooks::Update;
# everything to do with the update hook
# ----------------------------------------------------------------------
@EXPORT = qw(
update
update_hook
);
use Exporter 'import';
use lib $ENV{GL_BINDIR};
use Gitolite::Common;
use Gitolite::Conf::Load;
use strict;
use warnings;
# ----------------------------------------------------------------------
sub update {
trace( 3, @_ );
# this is the *real* update hook for gitolite
my ( $ref, $oldsha, $newsha, $oldtree, $newtree, $aa ) = args(@ARGV);
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 if $ret =~ /DENIED/;
exit 0;
}
{
my $text = '';
sub update_hook {
trace(1);
if ( not $text ) {
local $/ = undef;
$text = <DATA>;
}
return $text;
}
}
# ----------------------------------------------------------------------
sub args {
my ( $ref, $oldsha, $newsha ) = @_;
my ( $oldtree, $newtree, $aa );
# this is special to git -- the hash of an empty tree
my $empty = '4b825dc642cb6eb9a060e54bf8d69288fbee4904';
$oldtree = $oldsha eq '0' x 40 ? $empty : $oldsha;
$newtree = $newsha eq '0' x 40 ? $empty : $newsha;
my $merge_base = '0' x 40;
# for branch create or delete, merge_base stays at '0'x40
chomp( $merge_base = `git merge-base $oldsha $newsha` )
unless $oldsha eq '0' x 40
or $newsha eq '0' x 40;
$aa = 'W';
# tag rewrite
$aa = '+' if $ref =~ m(refs/tags/) and $oldsha ne ( '0' x 40 );
# non-ff push to ref (including ref delete)
$aa = '+' if $oldsha ne $merge_base;
# XXX $aa = 'D' if ( $repos{$ENV{GL_REPO}}{DELETE_IS_D} or $repos{'@all'}{DELETE_IS_D} ) and $newsha eq '0' x 40;
# XXX $aa = 'C' if ( $repos{$ENV{GL_REPO}}{CREATE_IS_C} or $repos{'@all'}{CREATE_IS_C} ) and $oldsha eq '0' x 40;
# and now "M" commits. This presents a bit of a problem. All the other
# accesses (W, +, C, D) were mutually exclusive in some sense. Sure a W could
# be a C or a + could be a D but that's by design. A merge commit, however,
# could still be any of the others (except a "D").
# so we have to *append* 'M' to $aa (if the repo has MERGE_CHECK in
# effect and this push contains a merge inside)
=for XXX
if ( $repos{ $ENV{GL_REPO} }{MERGE_CHECK} or $repos{'@all'}{MERGE_CHECK} ) {
if ( $oldsha eq '0' x 40 or $newsha eq '0' x 40 ) {
warn "ref create/delete ignored for purposes of merge-check\n";
} else {
$aa .= 'M' if `git rev-list -n 1 --merges $oldsha..$newsha` =~ /./;
}
}
=cut
return ( $ref, $oldsha, $newsha, $oldtree, $newtree, $aa );
}
1;
__DATA__
#!/usr/bin/perl
use strict;
use warnings;
BEGIN {
exit 0 if $ENV{GL_BYPASS_UPDATE_HOOK};
die "GL_BINDIR not set; aborting\n" unless $ENV{GL_BINDIR};
}
use lib $ENV{GL_BINDIR};
use Gitolite::Hooks::Update;
# gitolite update hook
# ----------------------------------------------------------------------
update(@ARGV); # is not expected to return
exit 1; # so if it does, something is wrong

112
Gitolite/Rc.pm Normal file
View file

@ -0,0 +1,112 @@
package Gitolite::Rc;
# everything to do with 'rc'. Also defines some 'constants'
# ----------------------------------------------------------------------
@EXPORT = qw(
$GL_ADMIN_BASE
$GL_REPO_BASE
$GL_UMASK
$GL_GITCONFIG_KEYS
glrc_default_text
glrc_default_filename
glrc_filename
$ADC_CMD_ARGS_PATT
$REF_OR_FILENAME_PATT
$REPONAME_PATT
$REPOPATT_PATT
$USERNAME_PATT
$current_data_version
);
use Exporter 'import';
use lib $ENV{GL_BINDIR};
use Gitolite::Common;
# variables that are/could be/should be in the rc file
# ----------------------------------------------------------------------
$GL_ADMIN_BASE = "$ENV{HOME}/.gitolite";
$GL_REPO_BASE = "$ENV{HOME}/repositories";
# variables that should probably never be changed
# ----------------------------------------------------------------------
$current_data_version = "3.0";
$ADC_CMD_ARGS_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._\@/,-]*$);
$USERNAME_PATT = qr(^\@?[0-9a-zA-Z][0-9a-zA-Z._\@+-]*$);
# ----------------------------------------------------------------------
use strict;
use warnings;
# ----------------------------------------------------------------------
my $rc = glrc_filename();
do $rc if -r $rc;
{
my $glrc_default_text = '';
sub glrc_default_text {
trace( 1, "..should happen only on first run" );
return $glrc_default_text if $glrc_default_text;
local $/ = undef;
$glrc_default_text = <DATA>;
}
}
sub glrc_default_filename {
trace( 1, "..should happen only on first run" );
return "$ENV{HOME}/.gitolite.rc";
}
# where is the rc file?
sub glrc_filename {
trace(4);
# search $HOME first
return "$ENV{HOME}/.gitolite.rc" if -f "$ENV{HOME}/.gitolite.rc";
trace( 2, "$ENV{HOME}/.gitolite.rc not found" );
# XXX for fedora, we can add the following line, but I would really prefer
# if ~/.gitolite.rc on each $HOME was just a symlink to /etc/gitolite.rc
# XXX return "/etc/gitolite.rc" if -f "/etc/gitolite.rc";
return '';
}
1;
# ----------------------------------------------------------------------
__DATA__
# configuration variables for gitolite
# PLEASE READ THE DOCUMENTATION BEFORE EDITING OR ASKING QUESTIONS
# 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
$GL_UMASK = 0077;
$GL_GITCONFIG_KEYS = "";
# ------------------------------------------------------------------------------
# per perl rules, this should be the last line in such a file:
1;
# Local variables:
# mode: perl
# End:
# vim: set syn=perl:

34
Gitolite/Test.pm Normal file
View file

@ -0,0 +1,34 @@
package Gitolite::Test;
# functions for the test code to use
# ----------------------------------------------------------------------
#<<<
@EXPORT = qw(
try
put
);
#>>>
use Exporter 'import';
use File::Path qw(mkpath);
use Carp qw(carp cluck croak confess);
BEGIN {
require Gitolite::Test::Tsh;
*{'try'} = \&Tsh::try;
*{'put'} = \&Tsh::put;
}
use strict;
use warnings;
# ----------------------------------------------------------------------
# required preamble for all tests
try "
DEF gsh = /TRACE: gsh.SOC=/
./g3-install -c admin
cd tsh_tempdir;
";
1;

624
Gitolite/Test/Tsh.pm Normal file
View file

@ -0,0 +1,624 @@
#!/usr/bin/perl
use 5.10.0;
# Tsh -- non interactive Testing SHell in perl
# TODO items:
# - allow an RC file to be used to add basic and extended commands
# - convert internal defaults to additions to the RC file
# - implement shell commands as you go
# - solve the "pass/fail" inconsistency between shell and perl
# - solve the pipes problem (use 'overload'?)
# ----------------------------------------------------------------------
# modules
package Tsh;
use Exporter 'import';
@EXPORT = qw(
try run AUTOLOAD
rc error_count text lines error_list put
cd tsh_tempdir
$HOME $PWD $USER
);
@EXPORT_OK = qw();
use Env qw(@PATH HOME PWD USER TSH_VERBOSE);
# other candidates:
# GL_ADMINDIR GL_BINDIR GL_RC GL_REPO_BASE_ABS GL_REPO GL_USER
use strict;
use warnings;
use Text::Tabs; # only used for formatting the usage() message
use Text::ParseWords;
use File::Temp qw(tempdir);
END { chdir( $ENV{HOME} ); }
# we need this END handler *after* the 'use File::Temp' above. Without
# this, if $PWD at exit was $tempdir, you get errors like "cannot remove
# path when cwd is [...] at /usr/share/perl5/File/Temp.pm line 902".
use Data::Dumper;
# ----------------------------------------------------------------------
# globals
my $rc; # return code from backticked (external) programs
my $text; # STDOUT+STDERR of backticked (external) programs
my $lec; # the last external command (the rc and text are from this)
my $cmd; # the current command
my $testnum; # current test number, for info in TAP output
my $testname; # current test name, for error info to user
my $line; # current line number
my $err_count; # count of test failures
my @errors_in; # list of testnames that errored
my $tick; # timestamp for git commits
my %autoloaded;
my $tempdir = '';
# ----------------------------------------------------------------------
# setup
# unbuffer STDOUT and STDERR
select(STDERR); $|++;
select(STDOUT); $|++;
# set the timestamp (needed only under harness)
test_tick() if $ENV{HARNESS_ACTIVE};
# ----------------------------------------------------------------------
# this is for one-liner access from outside, using @ARGV, as in:
# perl -MTsh -e 'tsh()' 'tsh command list'
# or via STDIN
# perl -MTsh -e 'tsh()' < file-containing-tsh-commands
# NOTE: it **exits**!
sub tsh {
my @lines;
if (@ARGV) {
# simple, single argument which is a readable filename
if ( @ARGV == 1 and $ARGV[0] !~ /\s/ and -r $ARGV[0] ) {
# take the contents of the file
@lines = <>;
} else {
# more than one argument *or* not readable filename
# just take the arguments themselves as the command list
@lines = @ARGV;
@ARGV = ();
}
} else {
# no arguments given, take STDIN
usage() if -t;
@lines = <>;
}
# and process them
try(@lines);
# print error summary by default
if ( not defined $TSH_VERBOSE ) {
say STDERR "$err_count error(s)" if $err_count;
}
exit $err_count;
}
# these two get called with series of tsh commands, while the autoload,
# (later) handles single commands
sub try {
$rc = $err_count = 0;
@errors_in = ();
# break up multiline arguments into separate lines
my @lines = map { split /\n/ } @_;
# and process them
rc_lines(@lines);
# bump err_count if the last command had a non-0 rc (that was apparently not checked).
$err_count++ if $rc;
# finish up...
dbg( 1, "$err_count error(s)" ) if $err_count;
return ( not $err_count );
}
# run() differs from try() in that
# - uses open(), not backticks
# - takes only one command, not tsh-things like ok, /patt/ etc
# - - if you pass it an array it uses the list form!
sub run {
open( my $fh, "-|", @_ ) or die "tell sitaram $!";
local $/ = undef; $text = <$fh>;
close $fh; warn "tell sitaram $!" if $!;
$rc = ( $? >> 8 );
return $text;
}
sub put {
my ( $file, $data ) = @_;
die "probable quoting error in arguments to put: $file\n" if $file =~ /^\s*['"]/;
my $mode = ">";
$mode = "|-" if $file =~ s/^\s*\|\s*//;
$rc = 0;
my $fh;
open( $fh, $mode, $file )
and print $fh $data
and close $fh
and return 1;
$rc = 1;
dbg( 1, "put $file: $!" );
return '';
}
# ----------------------------------------------------------------------
# TODO: AUTOLOAD and exportable convenience subs for common shell commands
sub cd {
my $dir = shift || '';
_cd($dir);
dbg( 1, "cd $dir: $!" ) if $rc;
return ( not $rc );
}
# this is classic AUTOLOAD, almost from the perlsub manpage. Although, if
# instead of `ls('bin');` you want to be able to say `ls 'bin';` you will need
# to predeclare ls, with `sub ls;`.
sub AUTOLOAD {
my $program = $Tsh::AUTOLOAD;
dbg( 4, "program = $program, arg=$_[0]" );
$program =~ s/.*:://;
$autoloaded{$program}++;
die "tsh's autoload support expects only one arg\n" if @_ > 1;
_sh("$program $_[0]");
return ( not $rc ); # perl truth
}
# ----------------------------------------------------------------------
# exportable service subs
sub rc {
return $rc || 0;
}
sub text {
return $text || '';
}
sub lines {
return split /\n/, $text;
}
sub error_count {
return $err_count;
}
sub error_list {
return (
wantarray
? @errors_in
: join( "\n", @errors_in )
);
}
sub tsh_tempdir {
# create tempdir if not already done
$tempdir = tempdir( "tsh_tempdir.XXXXXXXXXX", TMPDIR => 1, CLEANUP => 1 ) unless $tempdir;
# XXX TODO that 'UNLINK' doesn't work for Ctrl_C
return $tempdir;
}
# ----------------------------------------------------------------------
# internal (non-exportable) service subs
sub print_plan {
return unless $ENV{HARNESS_ACTIVE};
my $_ = shift;
say "1..$_";
}
sub rc_lines {
my @lines = @_;
while (@lines) {
my $_ = shift @lines;
chomp; $_ = trim_ws($_);
# this also sets $testname
next if is_comment_or_empty($_);
dbg( 2, "L: $_" );
$line = $_; # save line for printing with 'FAIL:'
# a DEF has to be on a line by itself
if (/^DEF\s+([-.\w]+)\s*=\s*(\S.*)$/) {
def( $1, $2 );
next;
}
my @cmds = cmds($_);
# process each command
# (note: some of the commands may put stuff back into @lines)
while (@cmds) {
# this needs to be the 'global' one, since fail() prints it
$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+(.*))?$) );
# warn if the previous command failed but rc is not being checked
if ( $rc and not $testing_cmd ) {
dbg( 1, "rc: $rc from cmd prior to '$cmd'\n" );
# count this as a failure, for exit status purposes
$err_count++;
# and reset the rc, otherwise for example 'ls foo; tt; tt; tt'
# will tell you there are 3 errors!
$rc = 0;
push @errors_in, $testname if $testname;
}
# prepare to run the command
dbg( 3, "C: $cmd" );
if ( def($cmd) ) {
# expand macro and replace head of @cmds (unshift)
dbg( 2, "DEF: $cmd" );
unshift @cmds, cmds( def($cmd) );
} else {
parse($cmd);
}
# reset rc if checking is done
$rc = 0 if $testing_cmd;
# assumes you will (a) never have *both* 'ok' and '!ok' after
# an action command, and (b) one of them will come immediately
# after the action command, with /patt/ only after it.
}
}
}
sub def {
my ( $cmd, $list ) = @_;
state %def;
%def = read_rc_file() unless %def;
if ($list) {
# set mode
die "attempt to redefine macro $cmd\n" if $def{$cmd};
$def{$cmd} = $list;
return;
}
# get mode: split the $cmd at spaces, see if there is a definition
# available, substitute any %1, %2, etc., in it and send it back
my ( $c, @d ) = shellwords($cmd);
my $e; # the expanded value
if ( $e = $def{$c} ) { # starting value
for my $i ( 1 .. 9 ) {
last unless $e =~ /%$i/; # no more %N's (we assume sanity)
die "$def{$c} requires more arguments\n" unless @d;
my $f = shift @d; # get the next datum
$e =~ s/%$i/$f/g; # and substitute %N all over
}
return join( " ", $e, @d ); # join up any remaining data
}
return '';
}
sub _cd {
my $dir = shift || $HOME;
# a directory name of 'tsh_tempdir' is special
$dir = tsh_tempdir() if $dir eq 'tsh_tempdir';
$rc = 0;
chdir($dir) or $rc = 1;
}
sub _sh {
my $cmd = shift;
# TODO: switch to IPC::Open3 or something...?
dbg( 4, " running: ( $cmd ) 2>&1" );
$text = `( $cmd ) 2>&1; echo -n RC=\$?`;
$lec = $cmd;
dbg( 4, " results:\n$text" );
if ( $text =~ /RC=(\d+)$/ ) {
$rc = $1;
$text =~ s/RC=\d+$//;
} else {
die "couldnt find RC= in result; this should not happen:\n$text\n\n...\n";
}
}
sub _perl {
my $perl = shift;
local $_;
$_ = $text;
dbg( 4, " eval: $perl" );
my $evrc = eval $perl;
if ($@) {
$rc = 1; # shell truth
dbg( 1, $@ );
# leave $text unchanged
} else {
$rc = not $evrc;
# $rc is always shell truth, so we need to cover the case where
# there was no error but it still returned a perl false
$text = $_;
}
dbg( 4, " eval-rc=$evrc, results:\n$text" );
}
sub parse {
my $cmd = shift;
if ( $cmd =~ /^sh (.*)/ ) {
_sh($1);
} elsif ( $cmd =~ /^perl (.*)/ ) {
_perl($1);
} elsif ( $cmd eq 'tt' or $cmd eq 'test-tick' ) {
test_tick();
} elsif ( $cmd =~ /^plan ?(\d+)$/ ) {
print_plan($1);
} elsif ( $cmd =~ /^cd ?(\S*)$/ ) {
_cd($1);
} elsif ( $cmd =~ /^ENV (\w+)=['"]?(.+?)['"]?$/ ) {
$ENV{$1} = $2;
} elsif ( $cmd =~ /^(?:tc|test-commit)\s+(\S.*)$/ ) {
# this is the only "git special" really; the default expansions are
# just that -- defaults. But this one is hardwired!
dummy_commits($1);
} elsif ( $cmd =~ '^put(?:\s+(\S.*))?$' ) {
if ($1) {
put( $1, $text );
} else {
print $text if defined $text;
}
} elsif ( $cmd =~ m(^ok(?:\s+or\s+(.*))?$) ) {
$rc ? fail( "ok, rc=$rc from $lec", $1 || '' ) : ok();
} elsif ( $cmd =~ m(^!ok(?:\s+or\s+(.*))?$) ) {
$rc ? ok() : fail( "!ok, rc=0 from $lec", $1 || '' );
} elsif ( $cmd =~ m(^/(.*?)/(?:\s+or\s+(.*))?$) ) {
expect( $1, $2 );
} elsif ( $cmd =~ m(^!/(.*?)/(?:\s+or\s+(.*))?$) ) {
not_expect( $1, $2 );
} else {
_sh($cmd);
}
}
# currently unused
sub executable {
my $cmd = shift;
# path supplied
$cmd =~ m(/) and -x $cmd and return 1;
# barename; look up in $PATH
for my $p (@PATH) {
-x "$p/$cmd" and return 1;
}
return 0;
}
sub ok {
$testnum++;
say "ok ($testnum)" if $ENV{HARNESS_ACTIVE};
}
sub fail {
$testnum++;
say "not ok ($testnum)" if $ENV{HARNESS_ACTIVE};
my $die = 0;
my ( $msg1, $msg2 ) = @_;
if ($msg2) {
# if arg2 is non-empty, print it regardless of debug level
$die = 1 if $msg2 =~ s/^die //;
say STDERR "# $msg2";
}
local $TSH_VERBOSE = 1 if $ENV{TSH_ERREXIT};
dbg( 1, "FAIL: $msg1", $testname || '', "test number $testnum", "L: $line", "results:\n$text" );
# count the error and add the testname to the list if it is set
$err_count++;
push @errors_in, $testname if $testname;
return unless $die or $ENV{TSH_ERREXIT};
dbg( 1, "exiting at cmd $cmd\n" );
exit( $rc || 74 );
}
sub expect {
my ( $patt, $msg ) = @_;
$msg =~ s/^\s+// if $msg;
my $sm;
if ( $sm = sm($patt) ) {
dbg( 4, " M: $sm" );
ok();
} else {
fail( "/$patt/", $msg || '' );
}
}
sub not_expect {
my ( $patt, $msg ) = @_;
$msg =~ s/^\s+// if $msg;
my $sm;
if ( $sm = sm($patt) ) {
dbg( 4, " M: $sm" );
fail( "!/$patt/", $msg || '' );
} else {
ok();
}
}
sub sm {
# smart match? for now we just do regex match
my $patt = shift;
return ( $text =~ qr($patt) ? $& : "" );
}
sub trim_ws {
my $_ = shift;
s/^\s+//; s/\s+$//;
return $_;
}
sub is_comment_or_empty {
my $_ = shift;
chomp; $_ = trim_ws($_);
if (/^##\s(.*)/) {
$testname = $1;
say "# $1";
}
return ( /^#/ or /^$/ );
}
sub cmds {
my $_ = shift;
chomp; $_ = trim_ws($_);
# split on unescaped ';'s, then unescape the ';' in the results
my @cmds = map { s/\\;/;/g; $_ } split /(?<!\\);/;
@cmds = grep { $_ = trim_ws($_); /\S/; } @cmds;
return @cmds;
}
sub dbg {
return unless $TSH_VERBOSE;
my $level = shift;
return unless $TSH_VERBOSE >= $level;
my $all = join( "\n", grep( /./, @_ ) );
chomp($all);
$all =~ s/\n/\n\t/g;
say STDERR "# $all";
}
sub ddump {
for my $i (@_) {
print STDERR "DBG: " . Dumper($i);
}
}
sub usage {
# TODO
print "Please see documentation at:
https://github.com/sitaramc/tsh/blob/master/README.mkd
Meanwhile, here are your local 'macro' definitions:
";
my %m = read_rc_file();
my @m = map { "$_\t$m{$_}\n" } sort keys %m;
$tabstop = 16;
print join( "", expand(@m) );
exit 1;
}
# ----------------------------------------------------------------------
# git-specific internal service subs
sub dummy_commits {
for my $f ( split ' ', shift ) {
if ( $f eq 'tt' or $f eq 'test-tick' ) {
test_tick();
next;
}
my $ts = ( $tick ? localtime($tick) : localtime() );
_sh("echo $f at $ts >> $f && git add $f && git commit -m '$f at $ts'");
}
}
sub test_tick {
unless ( $ENV{HARNESS_ACTIVE} ) {
sleep 1;
return;
}
$tick += 60 if $tick;
$tick ||= 1310000000;
$ENV{GIT_COMMITTER_DATE} = "$tick +0530";
$ENV{GIT_AUTHOR_DATE} = "$tick +0530";
}
# ----------------------------------------------------------------------
# the internal macros, for easy reference and reading
sub read_rc_file {
my $rcfile = "$HOME/.tshrc";
my $rctext;
if ( -r $rcfile ) {
local $/ = undef;
open( my $rcfh, "<", $rcfile ) or die "this should not happen: $!\n";
$rctext = <$rcfh>;
} else {
# this is the default "rc" content
$rctext = "
add = git add
branch = git branch
clone = git clone
checkout = git checkout
commit = git commit
fetch = git fetch
init = git init
push = git push
reset = git reset
tag = git tag
empty = git commit --allow-empty -m empty
push-om = git push origin master
reset-h = git reset --hard
reset-hu = git reset --hard \@{u}
"
}
# ignore everything except lines of the form "aa = bb cc dd"
my %commands = ( $rctext =~ /^\s*([-.\w]+)\s*=\s*(\S.*)$/gm );
return %commands;
}
1;

35
g3-info Executable file
View file

@ -0,0 +1,35 @@
#!/usr/bin/perl
# gitolite shell, invoked from ~/.ssh/authorized_keys
# ----------------------------------------------------------------------
BEGIN {
# find and set bin dir
$ENV{GL_BINDIR} = "$ENV{HOME}/bin";
}
use lib $ENV{GL_BINDIR};
use Gitolite::Rc;
use Gitolite::Common;
use Gitolite::Conf::Load;
use strict;
use warnings;
# ----------------------------------------------------------------------
my $user = shift or die;
my $aa;
my $ref = 'unknown';
my $ret;
while (<>) {
chomp;
my $perm = '';
for $aa (qw(R W C)) {
$ret = access($_, $user, $aa, $ref);
$perm .= ( $ret =~ /DENIED/ ? " " : " $aa" );
}
print "$perm\t$_\n" if $perm =~ /\S/;
}

20
g3-install Executable file
View file

@ -0,0 +1,20 @@
#!/bin/bash
# this is specific to my test env; you may want to change it
set -e
cd /home/g3
if [ "$1" = "-c" ]
then
rm -rf .gito* gito* repositories proj* bin
mkdir bin
cp ~/.ssh/id_rsa.pub ~/.ssh/admin.pub
cd g3; cp -a gito* Gito* t/glt t/gito* ~/bin
gitolite setup -a ${2:-admin} -pk ~/.ssh/admin.pub
else
cd g3; cp -a gito* Gito* t/glt t/gito* ~/bin
gitolite setup
fi

54
gitolite Executable file
View file

@ -0,0 +1,54 @@
#!/usr/bin/perl
# all gitolite CLI tools run as sub-commands of this command
# ----------------------------------------------------------------------
=for usage
Usage: gitolite [sub-command] [options]
The following subcommands are available; they should all respond to '-h':
setup 1st run: initial setup; all runs: hook fixups
compile compile gitolite.conf
query-rc get values of rc variables
=cut
# ----------------------------------------------------------------------
use FindBin;
BEGIN { $ENV{GL_BINDIR} = $FindBin::Bin; }
use lib $ENV{GL_BINDIR};
use Gitolite::Common;
use strict;
use warnings;
# ----------------------------------------------------------------------
args();
# ----------------------------------------------------------------------
sub args {
my ( $command, @args ) = @ARGV;
usage() if not $command or $command eq '-h';
if ( $command eq 'setup' ) {
shift @ARGV;
require Gitolite::Commands::Setup;
Gitolite::Commands::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;
require Gitolite::Commands::QueryRc;
Gitolite::Commands::QueryRc->import;
query_rc();
}
}

57
gitolite-shell Executable file
View file

@ -0,0 +1,57 @@
#!/usr/bin/perl
# gitolite shell, invoked from ~/.ssh/authorized_keys
# ----------------------------------------------------------------------
BEGIN {
# find and set bin dir
$0 =~ m|^(/)?(.*)/| and $ENV{GL_BINDIR} = ( $1 || "$ENV{PWD}/" ) . $2;
}
use lib $ENV{GL_BINDIR};
use Gitolite::Rc;
use Gitolite::Common;
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";
# ----------------------------------------------------------------------
# XXX lots of stuff from gl-auth-command is missing for now...
# set up the user
my $user = $ENV{GL_USER} = shift;
# 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' );
# a ref of 'unknown' 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, 'unknown' );
trace( 1, "access($repo, $user, $aa, 'unknown') -> $ret" );
_die $ret if $ret =~ /DENIED/;
$repo = "'$GL_REPO_BASE/$repo.git'";
exec( "git", "shell", "-c", "$verb $repo" );
# ----------------------------------------------------------------------
sub split_soc {
my $soc = $ENV{SSH_ORIGINAL_COMMAND};
return ( $1, $2 ) if $soc =~ m(^(git-(?:upload|receive)-pack) '/?(.*?)(?:\.git)?'$);
_die "unknown command: $soc";
}
sub sanity {
my $repo = shift;
_die "'$repo' contains bad characters" if $repo !~ $REPONAME_PATT;
_die "'$repo' ends with a '/'" if $repo =~ m(/$);
_die "'$repo' contains '..'" if $repo =~ m(\.\.$);
}

106
src/gitolite Executable file
View file

@ -0,0 +1,106 @@
#!/usr/bin/perl
# all gitolite CLI tools run as sub-commands of this command
# ----------------------------------------------------------------------
=for args
Usage: gitolite [<sub-command>] [<options>]
The following built-in subcommands are available; they should all respond to
'-h' if 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
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
Warnings:
- list-users is disk bound and could take a while on sites with 1000s of repos
- list-memberships does not check if the name is known; unknown names come
back with 2 answers: the name itself and '@all'
In addition, running 'gitolite help' should give you a list of custom commands
available. They may or may not respond to '-h', depending on how they were
written.
=cut
# ----------------------------------------------------------------------
use FindBin;
BEGIN { $ENV{GL_BINDIR} = $FindBin::RealBin; }
use lib $ENV{GL_BINDIR};
use Gitolite::Rc;
use Gitolite::Common;
use strict;
use warnings;
# ----------------------------------------------------------------------
my ( $command, @args ) = @ARGV;
gl_log( 'gitolite', @ARGV ) if -d $rc{GL_ADMIN_BASE};
args();
# the first two commands need options via @ARGV, as they have their own
# GetOptions calls and older perls don't have 'GetOptionsFromArray'
if ( $command eq 'setup' ) {
shift @ARGV;
require Gitolite::Setup;
Gitolite::Setup->import;
setup();
} elsif ( $command eq 'query-rc' ) {
shift @ARGV;
query_rc();
# the rest don't need @ARGV per se
} elsif ( $command eq 'compile' ) {
require Gitolite::Conf;
Gitolite::Conf->import;
compile(@args);
} elsif ( $command eq 'trigger' ) {
trigger(@args);
} elsif ( -x "$rc{GL_BINDIR}/commands/$command" ) {
trace( 2, "attempting gitolite command $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-/ ) {
trace( 2, "attempting lister command $command" );
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';
}
# ----------------------------------------------------------------------
sub run_command {
my $pgm = shift;
my $fullpath = "$ENV{GL_BINDIR}/commands/$pgm";
_die "$pgm not found or not executable" if not -x $fullpath;
_system( $fullpath, @_ );
exit 0;
}

12
t/gitolite-receive-pack Executable file
View file

@ -0,0 +1,12 @@
#!/usr/bin/perl
use strict;
use warnings;
print STDERR "TRACE: grp(", join( ")(", @ARGV ), ")\n";
my $repo = shift;
$repo =~ s/\.git$//;
my $user = $ENV{G3T_USER} || 'no-such-user';
$ENV{SSH_ORIGINAL_COMMAND} = "git-receive-pack '$repo'";
exec( "$ENV{HOME}/bin/gitolite-shell", $user );

12
t/gitolite-upload-pack Executable file
View file

@ -0,0 +1,12 @@
#!/usr/bin/perl
use strict;
use warnings;
print STDERR "TRACE: gup(", join( ")(", @ARGV ), ")\n";
my $repo = shift;
$repo =~ s/\.git$//;
my $user = $ENV{G3T_USER} || 'no-such-user';
$ENV{SSH_ORIGINAL_COMMAND} = "git-upload-pack '$repo'";
exec( "$ENV{HOME}/bin/gitolite-shell", $user );

28
t/glt Executable file
View file

@ -0,0 +1,28 @@
#!/usr/bin/perl
use strict;
use warnings;
print STDERR "TRACE: glt(", join( ")(", @ARGV ), ")\n";
my $cmd = shift or die "need command";
my $user = shift or die "need user";
my $rc;
$ENV{G3T_USER} = $user;
if ( $cmd eq 'push' ) {
$rc = system( "git", $cmd, "--receive-pack=$ENV{HOME}/bin/gitolite-receive-pack", @ARGV );
} else {
$rc = system( "git", $cmd, "--upload-pack=$ENV{HOME}/bin/gitolite-upload-pack", @ARGV );
}
if ( $? == -1 ) {
die "F: failed to execute: $!\n";
} elsif ( $? & 127 ) {
printf STDERR "E: child died with signal %d\n", ( $? & 127 );
exit 1;
} else {
printf STDERR "W: child exited with value %d\n", $? >> 8 if $? >> 8;
exit( $? >> 8 );
}
exit 0;

110
t/t01-basic Executable file
View file

@ -0,0 +1,110 @@
#!/usr/bin/perl
use strict;
use warnings;
# this is hardcoded; change it if needed
use lib "$ENV{HOME}/bin";
use Gitolite::Test;
# basic tests
# ----------------------------------------------------------------------
try "
plan 74
## clone
glt clone dev2 file://gitolite-admin
!ok; gsh
/FATAL: DENIED: R access to gitolite-admin by dev2 .fallthru./
/fatal: The remote end hung up unexpectedly/
glt clone admin --progress file://gitolite-admin
ok; gsh
/Counting/; /Compressing/; /Total/
cd gitolite-admin; ok
";
put "conf/gitolite.conf", "
\@admins = admin dev1
repo gitolite-admin
- mm = \@admins
RW = \@admins
RW+ = admin
repo testing
RW+ = \@all
";
try "
## push
git add conf; ok
git status -s; ok; /M conf/gitolite.conf/
git commit -m t01a; ok; /master.*t01a/
glt push dev2 origin; !ok; gsh
/FATAL: DENIED: W access to gitolite-admin by dev2 .fallthru./
/fatal: The remote end hung up unexpectedly/
glt push admin origin; ok; /master -. master/
tsh empty; ok;
glt push admin origin master:mm
!ok; gsh
/FATAL: DENIED: W access to gitolite-admin by admin .rule: refs/heads/mm./
/remote: error: hook declined to update refs/heads/mm/
/To file://gitolite-admin/
/remote rejected. master -. mm .hook declined./
/error: failed to push some refs to 'file://gitolite-admin'/
";
put "conf/gitolite.conf", "
\@admins = admin dev1
repo gitolite-admin
RW+ = admin
repo testing
RW+ = \@all
repo t1
R = u2
RW = u3
RW+ = u4
";
try "
## push 2
git add conf; ok
git status -s; ok; /M conf/gitolite.conf/
git commit -m t01b; ok; /master.*t01b/
glt push admin origin; ok; gsh
/master -. master/
## clone
cd ..; ok;
glt clone u1 file://t1; !ok; gsh
/FATAL: DENIED: R access to t1 by u1 .fallthru./
/fatal: The remote end hung up unexpectedly/
glt clone u2 file://t1; ok; gsh
/warning: You appear to have cloned an empty repository./
ls -al t1; ok; /$ENV{USER}.*$ENV{USER}.*\.git/
cd t1; ok;
## push
test-commit tc1 tc2 tc2; ok; /f7153e3/
glt push u2 origin; !ok; gsh
/FATAL: DENIED: W access to t1 by u2 .fallthru./
/fatal: The remote end hung up unexpectedly/
glt push u3 origin master; ok; gsh
/master -. master/
## rewind
reset-h HEAD^; ok; /HEAD is now at 537f964 tc2/
test-tick; test-commit tc3; ok; /a691552/
glt push u3 origin; !ok; gsh
/rejected.*master -. master.*non-fast-forward./
glt push u3 -f origin; !ok; gsh
/FATAL: DENIED: \\+ access to t1 by u3 .fallthru./
/remote: error: hook declined to update refs/heads/master/
/To file://t1/
/remote rejected. master -. master .hook declined./
/error: failed to push some refs to 'file://t1'/
glt push u4 origin +master; ok; gsh
/ \\+ f7153e3...a691552 master -. master.*forced update./
"