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

install/test made easy (WARNING: read below)

Browse source 
(1) testing is very easy, just run this from a clone

        t/g3-clean-install-setup-test

    BUT BE WARNED THIS IS DESTRUCTIVE; details in t/WARNING

(2) install is equally simple; see 'INSTALL' in the main directory
This commit is contained in:
Sitaram Chamarty 2012-03-10 18:56:29 +05:30
parent acb2f8fe8e
commit 379b0c9549
25 changed files with 162 additions and 494 deletions
Download patch file Download diff file Expand all files Collapse all files

222
src/Gitolite/Common.pm Normal file
View file

@ -0,0 +1,222 @@
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 list_phy_repos
say2 _die _system slurp tsh_lines
trace cleanup_conf_line 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 _system {
if ( system(@_) != 0 ) {
say2 "system @_ failed";
if ( $? == -1 ) {
die "failed to execute: $!\n";
} elsif ( $? & 127 ) {
die "child died with signal " . ( $? & 127 ) . "\n";
} else {
die "child exited with value " . ( $? >> 8 ) . "\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;
}
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;
}
{
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.,
# 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 sort_u(\@phy_repos);
}
}
# ----------------------------------------------------------------------
# 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;

78
src/Gitolite/Conf.pm Normal file
View file

@ -0,0 +1,78 @@
package Gitolite::Conf;
# explode/parse a conf file
# ----------------------------------------------------------------------
@EXPORT = qw(
compile
explode
parse
);
use Exporter 'import';
use Getopt::Long;
use Gitolite::Common;
use Gitolite::Rc;
use Gitolite::Conf::Sugar;
use Gitolite::Conf::Store;
use strict;
use warnings;
# ----------------------------------------------------------------------
sub compile {
trace(3);
# XXX assume we're in admin-base/conf
_chdir( $rc{GL_ADMIN_BASE} );
_chdir("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
new_repos();
store();
}
sub parse {
my $lines = shift;
trace(4, scalar(@$lines) . " lines incoming");
for my $line (@$lines) {
# 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( ' ', ( $rc{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";
}
}
}
1;

120
src/Gitolite/Conf/Explode.pm Normal file
View file

@ -0,0 +1,120 @@
package Gitolite::Conf::Explode;
# include/subconf processor
# ----------------------------------------------------------------------
@EXPORT = qw(
explode
);
use Exporter 'import';
use Gitolite::Common;
use strict;
use warnings;
# ----------------------------------------------------------------------
# 'seen' for include/subconf files
my %included = ();
# 'seen' for group names on LHS
my %prefixed_groupname = ();
sub explode {
trace( 4, @_ );
my ( $file, $subconf, $out ) = @_;
# seed the 'seen' list if it's empty
$included{ device_inode("conf/gitolite.conf") }++ unless %included;
my $fh = _open( "<", $file );
while (<$fh>) {
my $line = cleanup_conf_line($_);
next unless $line =~ /\S/;
$line = prefix_groupnames( $line, $subconf ) if $subconf ne 'master';
if ( $line =~ /^(include|subconf) (\S.+)$/ ) {
incsub( $1, $2, $subconf, $out );
} else {
# normal line, send it to the callback function
push @{$out}, $line;
}
}
}
sub incsub {
my $is_subconf = ( +shift eq 'subconf' );
my ( $include_glob, $subconf, $out ) = @_;
_die "subconf $subconf attempting to run 'subconf'\n" if $is_subconf and $subconf ne 'master';
_die "invalid include/subconf file/glob '$include_glob'"
unless $include_glob =~ /^"(.+)"$/
or $include_glob =~ /^'(.+)'$/;
$include_glob = $1;
# 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 $rc{GL_ADMIN_BASE}/conf, not *explicitly*
# for my $file (glob($include_glob =~ m(^/) ? $include_glob : "$rc{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) {
push @{$out}, "subconf $basename";
explode( $file, $basename, $out );
push @{$out}, "subconf $subconf";
# XXX g2 delegaton compat: deal with this: $subconf_seen++;
} else {
explode( $file, $subconf, $out );
}
}
}
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;
$prefixed_groupname{$subconf}{"\@$lhs"} = "\@$subconf.$lhs";
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;

304
src/Gitolite/Conf/Load.pm Normal file
View file

@ -0,0 +1,304 @@
package Gitolite::Conf::Load;
# load conf data from stored files
# ----------------------------------------------------------------------
@EXPORT = qw(
load
access
list_groups
list_users
list_repos
list_memberships
list_members
);
use Exporter 'import';
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..." );
load_common();
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 'any';
# rule matches if ref matches or ref is any (see gitolite-shell)
next unless $ref =~ /^$refex/ or $ref eq 'any';
trace( 3, "DENIED by $refex" ) if $perm eq '-';
return "$aa $ref $repo $user DENIED by $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 "$aa $ref $repo $user DENIED by fallthru";
}
# ----------------------------------------------------------------------
sub load_common {
_chdir( $rc{GL_ADMIN_BASE} );
# 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 );
_chdir( $rc{GL_REPO_BASE} );
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 glrc('current-data-version');
}
# ----------------------------------------------------------------------
# api functions
# ----------------------------------------------------------------------
# list all groups
sub list_groups {
die "
Usage: gitolite list-groups
- lists all group names in conf
- no options, no flags
" if @ARGV;
load_common();
my @g = ();
while ( my ( $k, $v ) = each(%groups) ) {
push @g, @{$v};
}
return ( sort_u( \@g ) );
}
sub list_users {
my $count = 0;
my $total = 0;
die "
Usage: gitolite list-users
- lists all users/user groups in conf
- no options, no flags
- WARNING: may be slow if you have thousands of repos
" if @ARGV;
load_common();
my @u = map { keys %{$_} } values %repos;
$total = scalar( keys %split_conf );
warn "WARNING: you have $total repos to check; this could take some time!\n" if $total > 100;
for my $one ( keys %split_conf ) {
load_1($one);
$count++; print STDERR "$count / $total\r" if not( $count % 100 ) and timer(5);
push @u, map { keys %{$_} } values %one_repo;
}
print STDERR "\n";
return ( sort_u( \@u ) );
}
sub list_repos {
die "
Usage: gitolite list-repos
- lists all repos/repo groups in conf
- no options, no flags
" if @ARGV;
load_common();
my @r = keys %repos;
push @r, keys %split_conf;
return ( sort_u( \@r ) );
}
sub list_memberships {
die "
Usage: gitolite list-memberships <name>
- list all groups a name is a member of
- takes one user/repo name
" if @ARGV and $ARGV[0] eq '-h' or not @ARGV and not @_;
my $name = ( @_ ? shift @_ : shift @ARGV );
load_common();
my @m = memberships($name);
return ( sort_u( \@m ) );
}
sub list_members {
die "
Usage: gitolite list-members <group name>
- list all members of a group
- takes one group name
" if @ARGV and $ARGV[0] eq '-h' or not @ARGV and not @_;
my $name = ( @_ ? shift @_ : shift @ARGV );
load_common();
my @m = ();
while ( my ( $k, $v ) = each(%groups) ) {
for my $g ( @{$v} ) {
push @m, $k if $g eq $name;
}
}
return ( sort_u( \@m ) );
}
# ----------------------------------------------------------------------
{
my $start_time = 0;
sub timer {
unless ($start_time) {
$start_time = time();
return 0;
}
my $elapsed = shift;
return 0 if time() - $start_time < $elapsed;
$start_time = time();
return 1;
}
}
1;

335
src/Gitolite/Conf/Store.pm Normal file
View file

@ -0,0 +1,335 @@
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 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( $rc{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( $rc{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( $rc{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
_chdir( $rc{GL_REPO_BASE} );
my $phy_repos = list_phy_repos(1);
for my $repo ( @{$phy_repos} ) {
store_1($repo);
}
_chdir( $rc{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;
}
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 = glrc('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("$rc{GL_ADMIN_BASE}/hooks/common");
_mkdir("$rc{GL_ADMIN_BASE}/hooks/gitolite-admin");
_print( "$rc{GL_ADMIN_BASE}/hooks/common/update", update_hook() );
_print( "$rc{GL_ADMIN_BASE}/hooks/gitolite-admin/post-update", post_update_hook() );
chmod 0755, "$rc{GL_ADMIN_BASE}/hooks/common/update";
chmod 0755, "$rc{GL_ADMIN_BASE}/hooks/gitolite-admin/post-update";
$hook_reset++;
}
# propagate user hooks
ln_sf( "$rc{GL_ADMIN_BASE}/hooks/common", "*", "$repo.git/hooks" );
# propagate admin hook
ln_sf( "$rc{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;

100
src/Gitolite/Conf/Sugar.pm Normal file
View file

@ -0,0 +1,100 @@
package Gitolite::Conf::Sugar;
# syntactic sugar for the conf file, including site-local macros
# ----------------------------------------------------------------------
@EXPORT = qw(
sugar
);
use Exporter 'import';
use Gitolite::Rc;
use Gitolite::Common;
use Gitolite::Conf::Explode;
use strict;
use warnings;
# ----------------------------------------------------------------------
sub sugar {
# gets a filename, returns a listref
my @lines = ();
explode(shift, 'master', \@lines);
my $lines;
$lines = \@lines;
# run through the sugar stack one by one
# first, user supplied sugar:
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} }) {
_warn "ignoring unreadable sugar script $s" if not -r $s;
do $s if -r $s;
$lines = sugar_script($lines);
$lines = [ grep /\S/, map { cleanup_conf_line($_) } @$lines ];
}
}
}
# then our stuff:
$lines = owner_desc($lines);
# $lines = name_vref($lines);
return $lines;
}
sub owner_desc {
my $lines = shift;
my @ret;
# XXX compat breakage: (1) adding repo/owner does not automatically add an
# entry to projects.list -- we need a post-procesor for that, and (2)
# removing the 'repo' line no longer suffices to remove the config entry
# from projects.list. Maybe the post-procesor should do that as well?
# owner = "owner name"
# -> config gitweb.owner = owner name
# description = "some long description"
# -> config gitweb.description = some long description
# category = "whatever..."
# -> config gitweb.category = whatever...
# older formats:
# repo = "some long description"
# repo = "owner name" = "some long description"
# -> config gitweb.owner = owner name
# -> config gitweb.description = some long description
for my $line (@$lines) {
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, "repo $repo";
push @ret, "config gitweb.description = $desc";
push @ret, "config gitweb.owner = $owner" if $owner;
} elsif ( $line =~ /^desc = (\S.*)/ ) {
push @ret, "config gitweb.description = $1";
} elsif ( $line =~ /^owner = (\S.*)/ ) {
push @ret, "config gitweb.owner = $1";
} elsif ( $line =~ /^category = (\S.*)/ ) {
push @ret, "config gitweb.category = $1";
} else {
push @ret, $line;
}
}
return \@ret;
}
1;

68
src/Gitolite/Hooks/PostUpdate.pm Normal file
View file

@ -0,0 +1,68 @@
package Gitolite::Hooks::PostUpdate;
# everything to do with the post-update hook
# ----------------------------------------------------------------------
@EXPORT = qw(
post_update
post_update_hook
);
use Exporter 'import';
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} = $rc{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

113
src/Gitolite/Hooks/Update.pm Normal file
View file

@ -0,0 +1,113 @@
package Gitolite::Hooks::Update;
# everything to do with the update hook
# ----------------------------------------------------------------------
@EXPORT = qw(
update
update_hook
);
use Exporter 'import';
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

113
src/Gitolite/Rc.pm
View file

@ -7,9 +7,8 @@ package Gitolite::Rc;
%rc
glrc
query_rc
version
$REMOTE_COMMAND_PATT
$ADC_CMD_ARGS_PATT
$REF_OR_FILENAME_PATT
$REPONAME_PATT
$REPOPATT_PATT
@ -37,7 +36,7 @@ $rc{GL_REPO_BASE} = "$ENV{HOME}/repositories";
# variables that should probably never be changed
# ----------------------------------------------------------------------
$REMOTE_COMMAND_PATT = qr(^[- 0-9a-zA-Z\@\%_=+:,./]*$);
$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._\@/,-]*$);
@ -49,17 +48,9 @@ my $current_data_version = "3.0";
my $rc = glrc('filename');
do $rc if -r $rc;
_die "$rc seems to be for older gitolite" if defined($GL_ADMINDIR);
# let values specified in rc file override our internal ones
@rc{ keys %RC } = values %RC;
# testing sometimes requires all of it to be overridden silently; use an
# env var that is highly unlikely to appear in real life :)
do $ENV{G3T_RC} if exists $ENV{G3T_RC} and -r $ENV{G3T_RC};
# fix PATH (TODO: do it only if 'gitolite' isn't in PATH)
$ENV{PATH} = "$ENV{GL_BINDIR}:$ENV{PATH}";
# ----------------------------------------------------------------------
use strict;
@ -76,15 +67,19 @@ my $glrc_default_text = '';
sub glrc {
my $cmd = shift;
if ( $cmd eq 'default-filename' ) {
trace( 1, "..should happen only on first run" );
return "$ENV{HOME}/.gitolite.rc";
} elsif ( $cmd eq 'default-text' ) {
trace( 1, "..should happen only on first run" );
return $glrc_default_text if $glrc_default_text;
_die "rc file default text not set; this should not happen!";
} elsif ( $cmd eq 'filename' ) {
# where is the rc file?
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
@ -99,68 +94,56 @@ sub glrc {
}
# ----------------------------------------------------------------------
# implements 'gitolite query-rc' and 'version'
# implements 'gitolite query-rc'
# ----------------------------------------------------------------------
# ----------------------------------------------------------------------
=for usage
my $all = 0;
my $nonl = 0;
sub query_rc {
my @vars = args();
no strict 'refs';
if ($all) {
for my $e ( sort keys %rc ) {
print "$e=" . ( defined( $rc{$e} ) ? $rc{$e} : 'undef' ) . "\n";
}
return;
}
print join( "\t", map { $rc{$_} || '' } @vars ) . ( $nonl ? '' : "\n" ) if @vars;
}
sub version {
my $version = '';
$version = '(unknown)';
for ("$rc{GL_ADMIN_BASE}/VERSION") {
$version = slurp($_) if -r $_;
}
chomp($version);
return $version;
}
# ----------------------------------------------------------------------
=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
gitolite query-rc <list of rc variables>
Example:
gitolite query-rc GL_ADMIN_BASE UMASK
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;
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 (sort keys %rc) {
print "$e=" . ( defined($rc{$e}) ? $rc{$e} : 'undef' ) . "\n";
}
return;
}
print join( "\t", map { $rc{$_} } @vars ) . "\n" if @vars;
}
# ----------------------------------------------------------------------
sub args {
my $help = 0;
GetOptions(
'all|a' => \$all,
'nonl|n' => \$nonl,
'help|h' => \$help,
) or usage();
usage("'-a' cannot be combined with other arguments") if $all and @ARGV;
return '-a' if $all;
usage() if not $all and not @ARGV or $help;
return @ARGV;
}
@ -172,36 +155,14 @@ sub args {
__DATA__
# configuration variables for gitolite
# 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!
# PLEASE READ THE DOCUMENTATION BEFORE EDITING OR ASKING QUESTIONS
# (Tip: perl allows a comma after the last item in a list also!)
# 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
%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 =>
[
'post-compile/ssh-authkeys',
],
# comment out or uncomment as needed
# these are available to remote users
COMMANDS =>
{
'help' => 1,
'info' => 1,
},
);
# ------------------------------------------------------------------------------

160
src/Gitolite/Setup.pm Normal file
View file

@ -0,0 +1,160 @@
package Gitolite::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 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
# $rc{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( $rc{GL_ADMIN_BASE} );
_chdir( $rc{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( $rc{GL_REPO_BASE} );
_chdir( $rc{GL_REPO_BASE} );
new_repo("gitolite-admin");
# commit the admin files to the admin repo
$ENV{GIT_WORK_TREE} = $rc{GL_ADMIN_BASE};
_chdir("$rc{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

46
src/Gitolite/Test.pm Normal file
View file

@ -0,0 +1,46 @@
package Gitolite::Test;
# functions for the test code to use
# ----------------------------------------------------------------------
#<<<
@EXPORT = qw(
try
put
text
);
#>>>
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;
*{'text'} = \&Tsh::text;
}
use strict;
use warnings;
# ----------------------------------------------------------------------
# required preamble for all tests
try "
DEF gsh = /TRACE: gsh.SOC=/
DEF reject = /hook declined to update/; /remote rejected.*hook declined/; /error: failed to push some refs to/
DEF AP_1 = cd ../gitolite-admin; ok or die cant find admin repo clone;
DEF AP_2 = AP_1; git add conf ; ok; git commit -m %1; ok; /master.* %1/
DEF ADMIN_PUSH = AP_2 %1; glt push admin origin; ok; gsh; /master -> master/
mkdir -p $ENV{HOME}/bin
ln -sf $ENV{PWD}/src/gitolite $ENV{PWD}/t/glt ~/bin
cd; rm -vrf .gito* gito* repositories
cd tsh_tempdir;
gitolite setup -a admin
" or die "could not setup the test environment; errors:\n\n" . text() . "\n\n";
1;

624
src/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;

117
src/gitolite
View file

@ -3,17 +3,14 @@
# all gitolite CLI tools run as sub-commands of this command
# ----------------------------------------------------------------------
=for args
Usage: gitolite [<sub-command>] [<options>]
=for usage
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:
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
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
@ -25,10 +22,6 @@ 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
# ----------------------------------------------------------------------
@ -45,62 +38,58 @@ 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;
sub args {
my ( $command, @args ) = @ARGV;
usage() if not $command or $command eq '-h';
if ( $command eq 'setup' ) {
shift @ARGV;
require Gitolite::Setup;
Gitolite::Setup->import;
setup();
} elsif ( $command eq 'compile' ) {
shift @ARGV;
_die "'gitolite compile' does not take any arguments" if @ARGV;
require Gitolite::Conf;
Gitolite::Conf->import;
compile();
} elsif ( $command eq 'query-rc' ) {
shift @ARGV;
query_rc();
} 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;
_chdir( $rc{GL_REPO_BASE} );
print "$_\n" for ( @{ list_phy_repos() } );
} elsif ( $command eq 'list-memberships' ) {
shift @ARGV;
require Gitolite::Conf::Load;
Gitolite::Conf::Load->import;
print "$_\n" for ( @{ list_memberships() } );
} elsif ( $command eq 'list-members' ) {
shift @ARGV;
require Gitolite::Conf::Load;
Gitolite::Conf::Load->import;
print "$_\n" for ( @{ list_members() } );
} else {
_die "unknown gitolite sub-command";
}
}

55
src/gitolite-shell Executable file
View file

@ -0,0 +1,55 @@
#!/usr/bin/perl
# gitolite shell, invoked from ~/.ssh/authorized_keys
# ----------------------------------------------------------------------
use FindBin;
BEGIN { $ENV{GL_BINDIR} = $FindBin::RealBin; }
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 '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 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(\.\.$);
}