summaryrefslogtreecommitdiffstats
path: root/src/lib
diff options
context:
space:
mode:
authorDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-27 09:55:51 +0000
committerDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-27 09:55:51 +0000
commit7685305e1f82212323ec32a321b1f5c623751b6c (patch)
treea1af617672e26aee4c1031a3aa83e8ff08f6a0a5 /src/lib
parentInitial commit. (diff)
downloadgitolite3-7685305e1f82212323ec32a321b1f5c623751b6c.tar.xz
gitolite3-7685305e1f82212323ec32a321b1f5c623751b6c.zip
Adding upstream version 3.6.12.upstream/3.6.12upstream
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to 'src/lib')
-rw-r--r--src/lib/Gitolite/Cache.pm161
-rw-r--r--src/lib/Gitolite/Common.pm422
-rw-r--r--src/lib/Gitolite/Conf.pm109
-rw-r--r--src/lib/Gitolite/Conf/Explode.pm118
-rw-r--r--src/lib/Gitolite/Conf/Load.pm704
-rw-r--r--src/lib/Gitolite/Conf/Store.pm411
-rw-r--r--src/lib/Gitolite/Conf/Sugar.pm202
-rw-r--r--src/lib/Gitolite/Easy.pm240
-rw-r--r--src/lib/Gitolite/Hooks/PostUpdate.pm75
-rw-r--r--src/lib/Gitolite/Hooks/Update.pm172
-rw-r--r--src/lib/Gitolite/Rc.pm688
-rw-r--r--src/lib/Gitolite/Setup.pm175
-rw-r--r--src/lib/Gitolite/Test.pm122
-rw-r--r--src/lib/Gitolite/Test/Tsh.pm645
-rw-r--r--src/lib/Gitolite/Triggers.pm33
-rw-r--r--src/lib/Gitolite/Triggers/Alias.pm128
-rw-r--r--src/lib/Gitolite/Triggers/AutoCreate.pm24
-rw-r--r--src/lib/Gitolite/Triggers/CpuTime.pm52
-rwxr-xr-xsrc/lib/Gitolite/Triggers/Kindergarten.pm99
-rw-r--r--src/lib/Gitolite/Triggers/Mirroring.pm256
-rw-r--r--src/lib/Gitolite/Triggers/Motd.pm29
-rw-r--r--src/lib/Gitolite/Triggers/RefexExpr.pm80
-rw-r--r--src/lib/Gitolite/Triggers/RepoUmask.pm62
-rw-r--r--src/lib/Gitolite/Triggers/Shell.pm66
-rw-r--r--src/lib/Gitolite/Triggers/TProxy.pm98
-rw-r--r--src/lib/Gitolite/Triggers/Writable.pm17
26 files changed, 5188 insertions, 0 deletions
diff --git a/src/lib/Gitolite/Cache.pm b/src/lib/Gitolite/Cache.pm
new file mode 100644
index 0000000..351a13e
--- /dev/null
+++ b/src/lib/Gitolite/Cache.pm
@@ -0,0 +1,161 @@
+package Gitolite::Cache;
+
+# cache stuff using an external database (redis)
+# ----------------------------------------------------------------------
+
+@EXPORT = qw(
+ cache_control
+ cache_wrap
+);
+
+use Exporter 'import';
+
+use Gitolite::Common;
+use Gitolite::Rc;
+use Storable qw(freeze thaw);
+use Redis;
+
+my $redis;
+
+my $redis_sock = "$ENV{HOME}/.redis-gitolite.sock";
+if ( -S $redis_sock ) {
+ _connect_redis();
+} else {
+ _start_redis();
+ _connect_redis();
+
+ # this redis db is a transient, caching only, db, so let's not
+ # accidentally use any stale data when if we're just starting up
+ cache_control('stop');
+ cache_control('start');
+}
+
+# ----------------------------------------------------------------------
+
+my %wrapped;
+my $ttl = ( $rc{CACHE_TTL} || ( $rc{GROUPLIST_PGM} ? 900 : 90000 ) );
+
+sub cache_control {
+ my $op = shift;
+ if ( $op eq 'stop' ) {
+ $redis->flushall();
+ } elsif ( $op eq 'start' ) {
+ $redis->set( 'cache-up', 1 );
+ } elsif ( $op eq 'flush' ) {
+ flush_repo(@_);
+ }
+}
+
+sub cache_wrap {
+ my $sub = shift;
+ my $tname = $sub; # this is what will show up in the trace output
+ trace( 3, "wrapping '$sub'" );
+ $sub = ( caller 1 )[0] . "::" . $sub if $sub !~ /::/;
+ return if $wrapped{$sub}++; # in case somehow it gets called twice for the same sub!
+
+ # collect names of wrapped subs into a redis 'set'
+ $redis->sadd( "SUBWAY", $sub ); # subway? yeah well they wrap subs don't they?
+
+ my $cref = eval '\&' . $sub;
+ my %opt = @_;
+ # rest of the options come in as a hash. 'list' says this functions
+ # returns a list. 'ttl' is a number to override the default ttl for
+ # the cached value.
+
+ no strict 'refs';
+ no warnings 'redefine';
+ *{$sub} = sub { # the wrapper function
+ my $key = join( ", ", @_ );
+ trace( 2, "$tname.args", @_ );
+
+ if ( cache_up() and defined( my $val = $redis->get("$sub: $key") ) ) {
+ # cache is up and we got a hit, return value from cache
+ if ( $opt{list} ) {
+ trace( 2, "$tname.getl", @{ thaw($val) } );
+ return @{ thaw($val) };
+ } else {
+ trace( 2, "$tname.get", $val );
+ return $val;
+ }
+ } else {
+ # cache is down or we got a miss, compute
+ my ( $r, @r );
+ if ( $opt{list} ) {
+ @r = $cref->(@_); # provide list context
+ trace( 2, "$tname.setl", @r );
+ } else {
+ $r = $cref->(@_); # provide scalar context
+ trace( 2, "$tname.set", $r );
+ }
+
+ # store computed value in cache if cache is up
+ if ( cache_up() ) {
+ $redis->set( "$sub: $key", ( $opt{list} ? freeze( \@r ) : $r ) );
+ $redis->expire( "$sub: $key", $opt{ttl} || $ttl );
+ trace( 2, "$tname.ttl", ( $opt{ttl} || $ttl ) );
+ }
+
+ return @r if $opt{list};
+ return $r;
+ }
+ };
+ trace( 3, "wrapped '$sub'" );
+}
+
+sub cache_up {
+ return $redis->exists('cache-up');
+}
+
+sub flush_repo {
+ my $repo = shift;
+
+ my @wrapped = $redis->smembers("SUBWAY");
+ for my $func (@wrapped) {
+ # if we wrap any more functions, make sure they're functions where the
+ # first argument is 'repo'
+ my @keys = $redis->keys("$func: $repo, *");
+ $redis->del( @keys ) if @keys;
+ }
+}
+
+# ----------------------------------------------------------------------
+
+sub _start_redis {
+ my $conf = join( "", <DATA> );
+ $conf =~ s/%HOME/$ENV{HOME}/g;
+
+ open( REDIS, "|-", "/usr/sbin/redis-server", "-" ) or die "start redis server failed: $!";
+ print REDIS $conf;
+ close REDIS;
+
+ # give it a little time to come up
+ select( undef, undef, undef, 0.2 );
+}
+
+sub _connect_redis {
+ $redis = Redis->new( sock => $redis_sock, encoding => undef ) or die "redis new failed: $!";
+ $redis->ping or die "redis ping failed: $!";
+}
+
+1;
+
+__DATA__
+# resources
+maxmemory 50MB
+port 0
+unixsocket %HOME/.redis-gitolite.sock
+unixsocketperm 700
+timeout 0
+databases 1
+
+# daemon
+daemonize yes
+pidfile %HOME/.redis-gitolite.pid
+dbfilename %HOME/.redis-gitolite.rdb
+dir %HOME
+
+# feedback
+loglevel notice
+logfile %HOME/.redis-gitolite.log
+
+# we don't save
diff --git a/src/lib/Gitolite/Common.pm b/src/lib/Gitolite/Common.pm
new file mode 100644
index 0000000..b06f967
--- /dev/null
+++ b/src/lib/Gitolite/Common.pm
@@ -0,0 +1,422 @@
+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
+ gen_lfn
+ gl_log
+
+ dd
+ t_start
+ t_lap
+
+ ssh_fingerprint_file
+ ssh_fingerprint_line
+
+ update_hook_present
+);
+#>>>
+use Exporter 'import';
+use File::Path qw(mkpath);
+use File::Temp qw(tempfile);
+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 {
+ gl_log( "\t" . join( ",", @_[ 1 .. $#_ ] ) ) if $_[0] <= 1 and defined $Gitolite::Rc::rc{LOG_EXTRA};
+
+ return unless defined( $ENV{D} );
+
+ my $level = shift; return if $ENV{D} < $level;
+ my $sub = ( caller 1 )[3] || ''; $sub =~ s/.*://;
+ if ( not $sub ) {
+ $sub = (caller)[1];
+ $sub =~ s(.*/(.*))(($1));
+ }
+ $sub .= ' ' x ( 31 - length($sub) );
+ say2 "$level\t$sub\t", join( "\t", @_ );
+}
+
+sub dbg {
+ use Data::Dumper;
+ return unless defined( $ENV{D} );
+ for my $i (@_) {
+ print STDERR "DBG: " . Dumper($i);
+ }
+}
+
+sub dd {
+ local $ENV{D} = 1;
+ dbg(@_);
+}
+
+{
+ my %start_times;
+
+ eval "require Time::HiRes";
+ # we just ignore any errors from this; nothing needs to be done as long as
+ # no code *calls* either of the next two functions.
+
+ sub t_start {
+ my $name = shift || 'default';
+ $start_times{$name} = [ Time::HiRes::gettimeofday() ];
+ }
+
+ sub t_lap {
+ my $name = shift || 'default';
+ return Time::HiRes::tv_interval( $start_times{$name} );
+ }
+}
+
+sub _warn {
+ gl_log( 'warn', @_ );
+ if ( $ENV{D} and $ENV{D} >= 3 ) {
+ cluck "WARNING: ", @_, "\n";
+ } elsif ( defined( $ENV{D} ) ) {
+ carp "WARNING: ", @_, "\n";
+ } else {
+ warn "WARNING: ", @_, "\n";
+ }
+}
+$SIG{__WARN__} = \&_warn;
+
+sub _die {
+ gl_log( '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";
+ }
+}
+$SIG{__DIE__} = \&_die;
+
+sub usage {
+ my $script = (caller)[1];
+ my $function = shift if @_ and $_[0] =~ /^[\w-]+$/;
+ $function ||= ( ( ( caller(1) )[3] ) || ( ( caller(0) )[3] ) );
+ $function =~ s/.*:://;
+ my $code = slurp($script);
+ $code =~ /^=for $function\b(.*?)^=cut/sm;
+ say( $1 ? $1 : "...no usage message for '$function' in $script" );
+ 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. This includes not guaranteeing
+ # dead symlinks or if mkpath traversal is blocked by a file.
+ 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 {
+ # run system(), catch errors. Be verbose only if $ENV{D} exists. If not,
+ # exit with <rc of system()> if it applies, else just "exit 1".
+ trace( 1, 'system', @_ );
+ if ( system(@_) != 0 ) {
+ trace( 1, "system() failed", @_, "-> $?" );
+ if ( $? == -1 ) {
+ die "failed to execute: $!\n" if $ENV{D};
+ } elsif ( $? & 127 ) {
+ die "child died with signal " . ( $? & 127 ) . "\n" if $ENV{D};
+ } else {
+ die "child exited with value " . ( $? >> 8 ) . "\n" if $ENV{D};
+ exit( $? >> 8 );
+ }
+ exit 1;
+ }
+}
+
+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 {
+ return unless defined wantarray;
+ local $/ = undef unless wantarray;
+ 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( 3, @_ );
+ 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;
+ return $line if $line =~ /^# \S+ \d+$/;
+
+ # 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 {
+ # 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 @_ );
+
+ my $cmd = 'find . ' . ($Gitolite::Rc::rc{REPO_SYMLINKS} || '') . ' -name "*.git" -prune';
+ for my $repo (`$cmd`) {
+ chomp($repo);
+ $repo =~ s/\.git$//;
+ $repo =~ s(^\./)();
+ next if $repo =~ m(/$);
+ # tolerate non-bare repos within ~/repositories but silently ignore them
+ push @phy_repos, $repo;
+ }
+ trace( 3, scalar(@phy_repos) . " physical repos found" );
+ return sort_u( \@phy_repos );
+ }
+}
+
+sub update_hook_present {
+ my $repo = shift;
+
+ return 1 unless -d "$ENV{GL_REPO_BASE}/$repo.git"; # non-existent repo is fine
+
+ my $x = readlink("$ENV{GL_REPO_BASE}/$repo.git/hooks/update");
+ return 1 if $x and $x eq "$ENV{GL_ADMIN_BASE}/hooks/common/update";
+
+ return 0;
+}
+
+# generate a timestamp
+sub gen_ts {
+ my ( $s, $min, $h, $d, $m, $y ) = (localtime)[ 0 .. 5 ];
+ $y += 1900; $m++; # usual adjustments
+ for ( $s, $min, $h, $d, $m ) {
+ $_ = "0$_" if $_ < 10;
+ }
+ my $ts = "$y-$m-$d.$h:$min:$s";
+
+ return $ts;
+}
+
+# generate a log file name
+sub gen_lfn {
+ my ( $s, $min, $h, $d, $m, $y ) = (localtime)[ 0 .. 5 ];
+ $y += 1900; $m++; # usual adjustments
+ for ( $s, $min, $h, $d, $m ) {
+ $_ = "0$_" if $_ < 10;
+ }
+
+ my ($template) = shift;
+ # substitute template parameters and set the logfile name
+ $template =~ s/%y/$y/g;
+ $template =~ s/%m/$m/g;
+ $template =~ s/%d/$d/g;
+
+ return $template;
+}
+
+my $log_dest;
+my $syslog_opened = 0;
+END { closelog() if $syslog_opened; }
+sub gl_log {
+ # the log filename and the timestamp come from the environment. If we get
+ # called even before they are set, we have no choice but to dump to STDERR
+ # (and probably call "logger").
+
+ # tab sep if there's more than one field
+ my $msg = join( "\t", @_ );
+ $msg =~ s/[\n\r]+/<<newline>>/g;
+
+ my $ts = gen_ts();
+ my $tid = $ENV{GL_TID} ||= $$;
+
+ $log_dest = $Gitolite::Rc::rc{LOG_DEST} || '' if not defined $log_dest;
+
+ # log (update records only) to "gl-log" in the bare repo dir; this is to
+ # make 'who-pushed' more efficient. Since this is only for the update
+ # records, it is not a replacement for the other two types of logging.
+ if ($log_dest =~ /repo-log/ and $_[0] eq 'update') {
+ # if the log line is 'update', we're already in the bare repo dir
+ open my $lfh, ">>", "gl-log" or _die "open gl-log failed: $!";
+ print $lfh "$ts\t$tid\t$msg\n";
+ close $lfh;
+ }
+
+ # syslog
+ if ($log_dest =~ /syslog/) { # log_dest *includes* syslog
+ if ($syslog_opened == 0) {
+ require Sys::Syslog;
+ Sys::Syslog->import(qw(:standard));
+
+ openlog("gitolite" . ( $ENV{GL_TID} ? "[$ENV{GL_TID}]" : "" ), "pid", $Gitolite::Rc::rc{LOG_FACILITY} || 'local0');
+ $syslog_opened = 1;
+ }
+
+ # gl_log is called either directly, or, if the rc variable LOG_EXTRA
+ # is set, from trace(1, ...). The latter use is considered additional
+ # info for troubleshooting. Trace prefixes a tab to the arguments
+ # before calling gl_log, to visually set off such lines in the log
+ # file. Although syslog eats up that leading tab, we use it to decide
+ # the priority/level of the syslog message.
+ syslog( ( $msg =~ /^\t/ ? 'debug' : 'info' ), "%s", $msg);
+
+ return if $log_dest !~ /normal/;
+ }
+
+ my $fh;
+ logger_plus_stderr( "errors found before logging could be setup", "$msg" ) if not $ENV{GL_LOGFILE};
+ open my $lfh, ">>", $ENV{GL_LOGFILE}
+ or logger_plus_stderr( "errors found but logfile could not be created", "$ENV{GL_LOGFILE}: $!", "$msg" );
+ print $lfh "$ts\t$tid\t$msg\n";
+ close $lfh;
+}
+
+sub logger_plus_stderr {
+ open my $fh, "|-", "logger" or confess "it's really not my day is it...?\n";
+ for (@_) {
+ print STDERR "FATAL: $_\n";
+ print $fh "FATAL: $_\n";
+ }
+ exit 1;
+}
+
+# ----------------------------------------------------------------------
+# Get the SSH fingerprint of a file
+# If the fingerprint cannot be parsed, it will be undef
+# In a scalar context, returns the fingerprint
+# In a list context, returns (fingerprint, output) where output
+# is the raw output of the ssh-keygen command
+sub ssh_fingerprint_file {
+ my $in = shift;
+ -f $in or die "file not found: $in\n";
+ my $fh;
+ open( $fh, "ssh-keygen -l -f $in 2>&1 |" ) or die "could not fork: $!\n";
+ my $output = <$fh>;
+ chomp $output;
+ # dbg("fp = $fp");
+ close $fh;
+ # Return a valid fingerprint or undef
+ my $fp = undef;
+ if($output =~ /((?:MD5:)?(?:[0-9a-f]{2}:){15}[0-9a-f]{2})/i or
+ $output =~ m{((?:RIPEMD|SHA)\d+:[A-Za-z0-9+/=]+)}i) {
+ $fp = $1;
+ }
+ return wantarray ? ($fp, $output) : $fp;
+}
+
+# Get the SSH fingerprint of a line of text
+# If the fingerprint cannot be parsed, it will be undef
+# In a scalar context, returns the fingerprint
+# In a list context, returns (fingerprint, output) where output
+# is the raw output of the ssh-keygen command
+sub ssh_fingerprint_line {
+ my ( $fh, $fn ) = tempfile();
+ print $fh shift() . "\n";
+ close $fh;
+ my ($fp,$output) = ssh_fingerprint_file($fn);
+ unlink $fn;
+ return wantarray ? ($fp,$output) : $fp;
+}
+
+# ----------------------------------------------------------------------
+
+# 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; printf RC=\$?`;
+ if ( $text =~ s/RC=(\d+)$// ) {
+ $rc = $1;
+ trace( 3, $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( 3, $text );
+ return $text;
+ }
+}
+
+1;
diff --git a/src/lib/Gitolite/Conf.pm b/src/lib/Gitolite/Conf.pm
new file mode 100644
index 0000000..97b6c32
--- /dev/null
+++ b/src/lib/Gitolite/Conf.pm
@@ -0,0 +1,109 @@
+package Gitolite::Conf;
+
+# explode/parse a conf file
+# ----------------------------------------------------------------------
+
+@EXPORT = qw(
+ compile
+ explode
+ parse
+);
+
+use Exporter 'import';
+
+use Gitolite::Rc;
+use Gitolite::Common;
+use Gitolite::Conf::Sugar;
+use Gitolite::Conf::Store;
+
+use strict;
+use warnings;
+
+# ----------------------------------------------------------------------
+
+sub compile {
+ _die "'gitolite compile' does not take any arguments" if @_;
+
+ _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();
+
+ # cache control
+ if ($rc{CACHE}) {
+ require Gitolite::Cache;
+ Gitolite::Cache->import(qw(cache_control));
+
+ cache_control('stop');
+ }
+
+ store();
+
+ if ($rc{CACHE}) {
+ cache_control('start');
+ }
+
+ # remove entries from POST_CREATE which also exist in POST_COMPILE. This
+ # not only saves us having to implement an optimisation in *those*
+ # scripts, but more importantly, moves the optimisation one step up -- we
+ # don't even *call* those scripts now.
+ my %pco = map { $_ => 1 } @{ $rc{POST_COMPILE} };
+ @{ $rc{POST_CREATE} } = grep { ! exists $pco{$_} } @{ $rc{POST_CREATE} };
+
+ for my $repo ( @{ $rc{NEW_REPOS_CREATED} } ) {
+ trigger( 'POST_CREATE', $repo );
+ }
+
+ # process rule template data
+ _system("gitolite compile-template-data");
+}
+
+sub parse {
+ my $lines = shift;
+ trace( 3, scalar(@$lines) . " lines incoming" );
+
+ my ( $fname, $lnum );
+ for my $line (@$lines) {
+ ( $fname, $lnum ) = ( $1, $2 ), next if $line =~ /^# (\S+) (\d+)$/;
+ # 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);
+
+ for my $ref (@refs) {
+ for my $user (@users) {
+ add_rule( $perm, $ref, $user, $fname, $lnum );
+ }
+ }
+ } elsif ( $line =~ /^config (.+) = ?(.*)/ ) {
+ my ( $key, $value ) = ( $1, $2 );
+ $value =~ s/^['"](.*)["']$/$1/;
+ my @validkeys = split( ' ', ( $rc{GIT_CONFIG_KEYS} || '' ) );
+ push @validkeys, "gitolite-options\\..*";
+ my @matched = grep { $key =~ /^$_$/i } @validkeys;
+ _die "git config '$key' not allowed\ncheck GIT_CONFIG_KEYS in the rc file" if ( @matched < 1 );
+ _die "bad config value '$value'" if $value =~ $UNSAFE_PATT;
+ while ( my ( $mk, $mv ) = each %{ $rc{SAFE_CONFIG} } ) {
+ $value =~ s/%$mk/$mv/g;
+ }
+ add_config( 1, $key, $value );
+ } elsif ( $line =~ /^subconf (\S+)$/ ) {
+ trace( 3, $line );
+ set_subconf($1);
+ } else {
+ _warn "syntax error, ignoring: '$line'";
+ }
+ }
+ parse_done();
+}
+
+1;
diff --git a/src/lib/Gitolite/Conf/Explode.pm b/src/lib/Gitolite/Conf/Explode.pm
new file mode 100644
index 0000000..cf89620
--- /dev/null
+++ b/src/lib/Gitolite/Conf/Explode.pm
@@ -0,0 +1,118 @@
+package Gitolite::Conf::Explode;
+
+# include/subconf processor
+# ----------------------------------------------------------------------
+
+@EXPORT = qw(
+ explode
+);
+
+use Exporter 'import';
+
+use Gitolite::Rc;
+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( 3, @_ );
+ my ( $file, $subconf, $out ) = @_;
+
+ # seed the 'seen' list if it's empty
+ $included{ device_inode("gitolite.conf") }++ unless %included;
+
+ my $fh = _open( "<", $file );
+ while (<$fh>) {
+ my $line = cleanup_conf_line($_);
+ next unless $line =~ /\S/;
+
+ # subst %HOSTNAME word if rc defines a hostname, else leave as is
+ $line =~ s/%HOSTNAME\b/$rc{HOSTNAME}/g if $rc{HOSTNAME};
+
+ $line = prefix_groupnames( $line, $subconf ) if $subconf ne 'master';
+
+ if ( $line =~ /^(include|subconf) (?:(\S+) )?(\S.+)$/ ) {
+ incsub( $1, $2, $3, $subconf, $out );
+ } else {
+ # normal line, send it to the callback function
+ push @{$out}, "# $file $.";
+ push @{$out}, $line;
+ }
+ }
+}
+
+sub incsub {
+ my $is_subconf = ( +shift eq 'subconf' );
+ my ( $new_subconf, $include_glob, $current_subconf, $out ) = @_;
+
+ _die "subconf '$current_subconf' attempting to run 'subconf'\n" if $is_subconf and $current_subconf ne 'master';
+
+ _die "invalid include/subconf file/glob '$include_glob'"
+ unless $include_glob =~ /^"(.+)"$/
+ or $include_glob =~ /^'(.+)'$/;
+ $include_glob = $1;
+
+ 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 " . ( $new_subconf || $basename );
+ explode( $file, ( $new_subconf || $basename ), $out );
+ push @{$out}, "subconf $current_subconf";
+ } else {
+ explode( $file, $current_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;
+
diff --git a/src/lib/Gitolite/Conf/Load.pm b/src/lib/Gitolite/Conf/Load.pm
new file mode 100644
index 0000000..7dea259
--- /dev/null
+++ b/src/lib/Gitolite/Conf/Load.pm
@@ -0,0 +1,704 @@
+package Gitolite::Conf::Load;
+
+# load conf data from stored files
+# ----------------------------------------------------------------------
+
+@EXPORT = qw(
+ load
+
+ access
+ git_config
+ env_options
+
+ option
+ repo_missing
+ creator
+
+ vrefs
+ lister_dispatch
+);
+
+use Exporter 'import';
+use Cwd;
+
+use Gitolite::Rc;
+use Gitolite::Common;
+
+use strict;
+use warnings;
+
+# ----------------------------------------------------------------------
+
+# our variables, because they get loaded by a 'do'
+our $data_version = '';
+our %repos;
+our %one_repo;
+our %groups;
+our %patterns;
+our %configs;
+our %one_config;
+our %split_conf;
+
+my $subconf = 'master';
+
+my %listers = (
+ 'list-groups' => \&list_groups,
+ 'list-users' => \&list_users,
+ 'list-repos' => \&list_repos,
+ 'list-memberships' => \&list_memberships,
+ 'list-members' => \&list_members,
+);
+
+# helps maintain the "cache" in both "load_common" and "load_1"
+my $last_repo = '';
+
+# ----------------------------------------------------------------------
+
+{
+ my $loaded_repo = '';
+
+ sub load {
+ my $repo = shift or _die "load() needs a reponame";
+ trace( 3, "$repo" );
+ if ( $repo ne $loaded_repo ) {
+ load_common();
+ load_1($repo);
+ $loaded_repo = $repo;
+ }
+ }
+}
+
+sub access {
+ my ( $repo, $user, $aa, $ref ) = @_;
+ trace( 2, $repo, $user, $aa, $ref );
+ _die "invalid user '$user'" if not( $user and $user =~ $USERNAME_PATT );
+ sanity($repo);
+ return "$aa any $repo $user DENIED by fallthru" unless update_hook_present($repo);
+
+ my @rules;
+ my $deny_rules;
+
+ load($repo);
+ @rules = rules( $repo, $user );
+ $deny_rules = option( $repo, 'deny-rules' );
+
+ # sanity check the only piece the user can control
+ _die "invalid characters in ref or filename: '$ref'\n" unless $ref =~ m(^VREF/NAME/) or $ref =~ $REF_OR_FILENAME_PATT;
+ # apparently we can't always force sanity; at least what we *return*
+ # should be sane/safe. This pattern is based on REF_OR_FILENAME_PATT.
+ ( my $safe_ref = $ref ) =~ s([^-0-9a-zA-Z._\@/+ :,])(.)g;
+ trace( 3, "safe_ref", $safe_ref ) if $ref ne $safe_ref;
+
+ # when a real repo doesn't exist, ^C is a pre-requisite for any other
+ # check to give valid results.
+ if ( $aa ne '^C' and $repo !~ /^\@/ and $repo =~ $REPONAME_PATT and repo_missing($repo) ) {
+ my $iret = access( $repo, $user, '^C', $ref );
+ $iret =~ s/\^C/$aa/;
+ return $iret if $iret =~ /DENIED/;
+ }
+ # similarly, ^C must be denied if the repo exists
+ if ( $aa eq '^C' and not repo_missing($repo) ) {
+ trace( 2, "DENIED by existence" );
+ return "$aa $safe_ref $repo $user DENIED by existence";
+ }
+
+ trace( 3, scalar(@rules) . " rules found" );
+
+ $rc{RULE_TRACE} = '';
+ for my $r (@rules) {
+ $rc{RULE_TRACE} .= " " . $r->[0] . " ";
+
+ my $perm = $r->[1];
+ my $refex = $r->[2]; $refex =~ s(/USER/)(/$user/);
+ trace( 3, "perm=$perm, refex=$refex" );
+
+ $rc{RULE_TRACE} .= "d";
+ # skip 'deny' rules if the ref is not (yet) known
+ next if $perm eq '-' and $ref eq 'any' and not $deny_rules;
+
+ $rc{RULE_TRACE} .= "r";
+ # rule matches if ref matches or ref is any (see gitolite-shell)
+ next unless $ref =~ /^$refex/ or $ref eq 'any';
+
+ $rc{RULE_TRACE} .= "D";
+ trace( 2, "DENIED by $refex" ) if $perm eq '-';
+ return "$aa $safe_ref $repo $user DENIED by $refex" if $perm eq '-';
+
+ # For repo creation, perm will be C and aa will be "^C". For branch
+ # access, $perm can be RW\+?(C|D|CD|DC)?M?, and $aa can be W, +, C or
+ # D, or any of these followed by "M".
+
+ # We need to turn $aa into a regex that can match a suitable $perm.
+ # This is trivially true for "^C", "W" and "D", but the others (+, C,
+ # M) need some tweaking.
+
+ # first, quote the '+':
+ ( my $aaq = $aa ) =~ s/\+/\\+/;
+ # if aa is just "C", the user is trying to create a *branch* (not a
+ # *repo*), so let's make the pattern clearer to reflect that.
+ $aaq = "RW.*C" if $aaq eq "C";
+ # if the aa is, say "WM", make this "W.*M" because the perm could be
+ # 'RW+M', 'RW+CDM' etc, and they are all valid:
+ $aaq =~ s/M/.*M/;
+
+ $rc{RULE_TRACE} .= "A";
+
+ # as far as *this* ref is concerned we're ok
+ return $refex if ( $perm =~ /$aaq/ );
+
+ $rc{RULE_TRACE} .= "p";
+ }
+ $rc{RULE_TRACE} .= " F";
+
+ trace( 2, "DENIED by fallthru" );
+ return "$aa $safe_ref $repo $user DENIED by fallthru";
+}
+
+# cache control
+if ($rc{CACHE}) {
+ require Gitolite::Cache;
+ Gitolite::Cache::cache_wrap('Gitolite::Conf::Load::access');
+}
+
+sub git_config {
+ my ( $repo, $key, $empty_values_OK ) = @_;
+ $key ||= '.';
+
+ if ( repo_missing($repo) ) {
+ load_common();
+ } else {
+ load($repo);
+ }
+
+ # read comments bottom up
+ my %ret =
+ # and take the second and third elements to make up your new hash
+ map { $_->[1] => $_->[2] }
+ # keep only the ones where the second element matches your key
+ grep { $_->[1] =~ qr($key) }
+ # sort this list of listrefs by the first element in each list ref'd to
+ sort { $a->[0] <=> $b->[0] }
+ # dereference it (into a list of listrefs)
+ map { @$_ }
+ # take the value of that entry
+ map { $configs{$_} }
+ # if it has an entry in %configs
+ grep { $configs{$_} }
+ # for each "repo" that represents us
+ memberships( 'repo', $repo );
+
+ # %configs looks like this (for each 'foo' that is in memberships())
+ # 'foo' => [ [ 6, 'foo.bar', 'repo' ], [ 7, 'foodbar', 'repoD' ], [ 8, 'foo.czar', 'jule' ] ],
+ # the first map gets you the value
+ # [ [ 6, 'foo.bar', 'repo' ], [ 7, 'foodbar', 'repoD' ], [ 8, 'foo.czar', 'jule' ] ],
+ # the deref gets you
+ # [ 6, 'foo.bar', 'repo' ], [ 7, 'foodbar', 'repoD' ], [ 8, 'foo.czar', 'jule' ]
+ # the sort rearranges it (in this case it's already sorted but anyway...)
+ # the grep gets you this, assuming the key is foo.bar (and "." is regex ".')
+ # [ 6, 'foo.bar', 'repo' ], [ 7, 'foodbar', 'repoD' ]
+ # and the final map does this:
+ # 'foo.bar'=>'repo' , 'foodbar'=>'repoD'
+
+ # now some of these will have an empty key; we need to delete them unless
+ # we're told empty values are OK
+ unless ($empty_values_OK) {
+ my ( $k, $v );
+ while ( ( $k, $v ) = each %ret ) {
+ delete $ret{$k} if not $v;
+ }
+ }
+
+ my ( $k, $v );
+ my $creator = creator($repo);
+ while ( ( $k, $v ) = each %ret ) {
+ $v =~ s/%GL_REPO/$repo/g;
+ $v =~ s/%GL_CREATOR/$creator/g if $creator;
+ $ret{$k} = $v;
+ }
+
+ map { trace( 3, "$_", "$ret{$_}" ) } ( sort keys %ret ) if $ENV{D};
+ return \%ret;
+}
+
+sub env_options {
+ return unless -f "$rc{GL_ADMIN_BASE}/conf/gitolite.conf-compiled.pm";
+ # prevent catch-22 during initial install
+
+ my $cwd = getcwd();
+
+ my $repo = shift;
+ map { delete $ENV{$_} } grep { /^GL_OPTION_/ } keys %ENV;
+ my $h = git_config( $repo, '^gitolite-options.ENV\.' );
+ while ( my ( $k, $v ) = each %$h ) {
+ next unless $k =~ /^gitolite-options.ENV\.(\w+)$/;
+ $ENV{ "GL_OPTION_" . $1 } = $v;
+ }
+
+ chdir($cwd);
+}
+
+sub option {
+ my ( $repo, $option ) = @_;
+ $option = "gitolite-options.$option";
+ my $ret = git_config( $repo, "^\Q$option\E\$" );
+ return '' unless %$ret;
+ return $ret->{$option};
+}
+
+sub sanity {
+ my ($repo, $patt) = @_;
+ $patt ||= $REPOPATT_PATT;
+
+ _die "invalid repo '$repo'" if not( $repo and $repo =~ $patt );
+ _die "'$repo' ends with a '/'" if $repo =~ m(/$);
+ _die "'$repo' contains '..'" if $repo =~ $REPONAME_PATT and $repo =~ m(\.\.);
+ _die "'$repo' contains '.git/'" if $repo =~ $REPONAME_PATT and $repo =~ m(\.git/);
+ _die "'$repo' ends with '.git'" if $repo =~ m(\.git$);
+}
+
+sub repo_missing {
+ my $repo = shift;
+ sanity($repo);
+
+ return not -d "$rc{GL_REPO_BASE}/$repo.git";
+}
+
+# ----------------------------------------------------------------------
+
+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;
+ }
+
+ 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;
+ return if $repo =~ /^\@/;
+ trace( 3, $repo );
+
+ if ( repo_missing($repo) ) {
+ trace( 1, "repo '$repo' missing" ) if $repo =~ $REPONAME_PATT;
+ return;
+ }
+ _chdir("$rc{GL_REPO_BASE}/$repo.git");
+
+ if ( $repo eq $last_repo ) {
+ $repos{$repo} = $one_repo{$repo};
+ $configs{$repo} = $one_config{$repo} if $one_config{$repo};
+ return;
+ }
+
+ if ( -f "gl-conf" ) {
+ return if not $split_conf{$repo} and not $rc{ALLOW_ORPHAN_GL_CONF};
+
+ my $cc = "./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};
+ }
+}
+
+{
+ my $lastrepo = '';
+ my $lastuser = '';
+ my @cached = ();
+
+ sub rules {
+ my ( $repo, $user ) = @_;
+ trace( 3, $repo, $user );
+
+ return @cached if ( $lastrepo eq $repo and $lastuser eq $user and @cached );
+
+ my @rules = ();
+
+ my @repos = memberships( 'repo', $repo );
+ my @users = memberships( 'user', $user, $repo );
+ trace( 3, "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} and exists $repos{$r}{$u};
+ }
+ }
+
+ @rules = sort { $a->[0] <=> $b->[0] } @rules;
+
+ $lastrepo = $repo;
+ $lastuser = $user;
+ @cached = @rules;
+
+ # however if the repo was missing, invalidate the cache
+ $lastrepo = '' if repo_missing($repo);
+
+ return @rules;
+ }
+
+ sub vrefs {
+ my ( $repo, $user ) = @_;
+ # fill the cache if needed
+ rules( $repo, $user ) unless ( $lastrepo eq $repo and $lastuser eq $user and @cached );
+
+ my %seen;
+ my @vrefs = grep { /^VREF\// and not $seen{$_}++ } map { $_->[2] } @cached;
+ return @vrefs;
+ }
+}
+
+sub memberships {
+ trace( 3, @_ );
+ my ( $type, $base, $repo ) = @_;
+ $repo ||= '';
+ my @ret;
+ my $base2 = '';
+
+ @ret = ( $base, '@all' );
+
+ if ( $type eq 'repo' ) {
+ # first, if a repo, say, pub/sitaram/project, has a gl-creator file
+ # that says "sitaram", find memberships for pub/CREATOR/project also
+ $base2 = generic_name($base);
+
+ # second, you need to check in %repos also
+ for my $i ( keys %repos, keys %configs ) {
+ if ( $base eq $i or $base =~ /^$i$/ or $base2 and ( $base2 eq $i or $base2 =~ /^$i$/ ) ) {
+ push @ret, $i;
+ }
+ }
+
+ # add in any group names explicitly given in (GIT_DIR)/gl-repo-groups
+ push @ret,
+ map { s/^\@?/\@/; $_ }
+ grep { ! /[^\w@-]/ }
+ split (' ', slurp("$ENV{GL_REPO_BASE}/$base.git/gl-repo-groups"))
+ if -f "$ENV{GL_REPO_BASE}/$base.git/gl-repo-groups";
+ }
+
+ push @ret, @{ $groups{$base} } if exists $groups{$base};
+ push @ret, @{ $groups{$base2} } if $base2 and exists $groups{$base2};
+ if ($type eq 'repo') {
+ # regexes can only be used for repos, not for users
+ for my $i ( keys %{ $patterns{groups} } ) {
+ if ( $base =~ /^$i$/ or $base2 and ( $base2 =~ /^$i$/ ) ) {
+ push @ret, @{ $groups{$i} };
+ }
+ }
+ }
+
+ push @ret, @{ ext_grouplist($base) } if $type eq 'user' and $rc{GROUPLIST_PGM};
+
+ if ( $type eq 'user' and $repo and not repo_missing($repo) ) {
+ # find the roles this user has when accessing this repo and add those
+ # in as groupnames he is a member of. You need the already existing
+ # memberships for this; see below this function for an example
+ push @ret, user_roles( $base, $repo, @ret );
+ }
+
+ @ret = @{ sort_u( \@ret ) };
+ trace( 3, sort @ret );
+ return @ret;
+}
+
+=for example
+
+conf/gitolite.conf:
+ @g1 = u1
+ @g2 = u1
+ # now user is a member of both g1 and g2
+
+gl-perms for repo being accessed:
+ READERS @g1
+
+This should result in @READERS being added to the memberships that u1 has
+(when accessing this repo). So we send the current list (@g1, @g2) to
+user_roles(), otherwise it has to redo that logic.
+
+=cut
+
+sub data_version_mismatch {
+ return $data_version ne glrc('current-data-version');
+}
+
+sub user_roles {
+ my ( $user, $repo, @eg ) = @_;
+
+ # eg == existing groups (that user is already known to be a member of)
+ my %eg = map { $_ => 1 } @eg;
+
+ my %ret = ();
+ my $f = "$rc{GL_REPO_BASE}/$repo.git/gl-perms";
+ my @roles = ();
+ if ( -f $f ) {
+ my $fh = _open( "<", $f );
+ chomp( @roles = <$fh> );
+ }
+ push @roles, "CREATOR = " . creator($repo);
+ for (@roles) {
+ # READERS u3 u4 @g1
+ s/^\s+//; s/ +$//; s/=/ /; s/\s+/ /g; s/^\@//;
+ next if /^#/;
+ next unless /\S/;
+ my ( $role, @members ) = split;
+ # role = READERS, members = u3, u4, @g1
+ if ( $role ne 'CREATOR' and not $rc{ROLES}{$role} ) {
+ _warn "role '$role' not allowed, ignoring";
+ next;
+ }
+ for my $m (@members) {
+ if ( $m !~ $USERNAME_PATT ) {
+ _warn "ignoring '$m' in perms line";
+ next;
+ }
+ # if user eq u3/u4, or is a member of @g1, he has role READERS
+ $ret{ '@' . $role } = 1 if $m eq $user or $eg{$m};
+ }
+ }
+
+ return keys %ret;
+}
+
+sub generic_name {
+ my $base = shift;
+ my $base2 = '';
+ my $creator;
+
+ # get the creator name. For not-yet-born repos this is $ENV{GL_USER},
+ # which should be set in all cases that we care about, viz., where we are
+ # checking ^C permissions before new_wild_repo(), and the info command.
+ # In particular, 'gitolite access' can't be used to check ^C perms on wild
+ # repos that contain "CREATOR" if GL_USER is not set.
+ $creator = creator($base);
+
+ $base2 = $base;
+ $base2 =~ s(\b$creator\b)(CREATOR) if $creator;
+ $base2 = '' if $base2 eq $base; # if there was no change
+
+ return $base2;
+}
+
+sub creator {
+ my $repo = shift;
+ sanity($repo);
+
+ return ( $ENV{GL_USER} || '' ) if repo_missing($repo);
+ my $f = "$rc{GL_REPO_BASE}/$repo.git/gl-creator";
+ my $creator = '';
+ chomp( $creator = slurp($f) ) if -f $f;
+ return $creator;
+}
+
+{
+ my %cache = ();
+
+ sub ext_grouplist {
+ my $user = shift;
+ my $pgm = $rc{GROUPLIST_PGM};
+ return [] if not $pgm;
+
+ return $cache{$user} if $cache{$user};
+ my @extgroups = map { s/^@?/@/; $_; } split ' ', `$rc{GROUPLIST_PGM} $user`;
+ return ( $cache{$user} = \@extgroups );
+ }
+}
+
+# ----------------------------------------------------------------------
+# api functions
+# ----------------------------------------------------------------------
+
+sub lister_dispatch {
+ my $command = shift;
+
+ my $fn = $listers{$command} or _die "unknown gitolite sub-command";
+ return $fn;
+}
+
+=for list_groups
+Usage: gitolite list-groups
+
+ - lists all group names in conf
+ - no options, no flags
+=cut
+
+sub list_groups {
+ usage() if @_;
+
+ load_common();
+
+ my @g = ();
+ while ( my ( $k, $v ) = each(%groups) ) {
+ push @g, @{$v};
+ }
+ return ( sort_u( \@g ) );
+}
+
+=for list_users
+Usage: gitolite list-users [<repo name pattern>]
+
+List all users and groups explicitly named in a rule.
+
+- you will have to run 'list-members' on each group name to expand it -- for
+ details and caveats on that please see its help message.
+- User names not mentioned in an access rule will not show up at all (for
+ example, if you have users who only have access via an '@all' rule).
+
+WARNING: may be slow if you have thousands of repos. The optional repo name
+pattern is an unanchored regex; it can speed things up if you're interested
+only in users of a matching set of repos. This is only an optimisation, not
+an actual access list; you will still have to pipe it to 'gitolite access'
+with appropriate arguments to get an actual access list.
+
+NOTE: If you're running in ssh mode, it may be simpler to parse the authorized
+keys file in ~/.ssh, like so:
+ perl -lne '/ ([a-z0-9]+)"/; print $1 if $1' < ~/.ssh/authorized_keys | sort -u
+If you're running in http mode, only your web server knows all the potential
+user names.
+=cut
+
+sub list_users {
+ my $patt = shift || '.';
+ usage() if $patt eq '-h' or @_;
+ my $count = 0;
+ my $total = 0;
+
+ load_common();
+
+ my @u = map { keys %{$_} } values %repos;
+ $total = scalar( grep { /$patt/ } keys %split_conf );
+ warn "WARNING: you have $total repos to check; this could take some time!\n" if $total > 100;
+ for my $one ( grep { /$patt/ } 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" if $count >= 100;
+ return ( sort_u( \@u ) );
+}
+
+=for list_repos
+Usage: gitolite list-repos
+
+ - lists all repos/repo groups in conf
+ - no options, no flags
+=cut
+
+sub list_repos {
+ usage() if @_;
+
+ load_common();
+
+ my @r = keys %repos;
+ push @r, keys %split_conf;
+
+ return ( sort_u( \@r ) );
+}
+
+=for list_memberships
+Usage: gitolite list-memberships -u|-r <name>
+
+List all groups a name is a member of. One of the flags '-u' or '-r' is
+mandatory, to specify if the name is a user or a repo.
+
+For users, the output includes the result from GROUPLIST_PGM, if it is
+defined. For repos, the output includes any repo patterns that the repo name
+matches, as well as any groups that contain those patterns.
+=cut
+
+sub list_memberships {
+ require Getopt::Long;
+
+ my ( $user, $repo, $help );
+
+ Getopt::Long::GetOptionsFromArray(
+ \@_,
+ 'user|u=s' => \$user,
+ 'repo|r=s' => \$repo,
+ 'help|h' => \$help,
+ );
+ usage() if $help or ( not $user and not $repo );
+
+ load_common();
+ my @m;
+
+ if ( $user and $repo ) {
+ # unsupported/undocumented except via "in_role()" in Easy.pm
+ @m = memberships( 'user', $user, $repo );
+ } elsif ($user) {
+ @m = memberships( 'user', $user );
+ } elsif ($repo) {
+ @m = memberships( 'repo', $repo );
+ }
+
+ @m = grep { $_ ne '@all' and $_ ne ( $user || $repo ) } @m;
+ return ( sort_u( \@m ) );
+}
+
+=for list_members
+Usage: gitolite list-members <group name>
+
+ - list all members of a group
+ - takes one group name
+
+'@all' is not expandable in this context. Also, if you have GROUPLIST_PGM set
+in your rc file[1], gitolite cannot expand group names completely; only your
+external database can.
+
+[1]: http://gitolite.com/gitolite/conf.html#ldap
+
+=cut
+
+sub list_members {
+ usage() if @_ and $_[0] eq '-h' or not @_;
+
+ my $name = shift;
+
+ 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;
+
diff --git a/src/lib/Gitolite/Conf/Store.pm b/src/lib/Gitolite/Conf/Store.pm
new file mode 100644
index 0000000..8757c89
--- /dev/null
+++ b/src/lib/Gitolite/Conf/Store.pm
@@ -0,0 +1,411 @@
+package Gitolite::Conf::Store;
+
+# receive parsed conf data and store it
+# ----------------------------------------------------------------------
+
+@EXPORT = qw(
+ add_to_group
+ set_repolist
+ parse_refs
+ parse_users
+ add_rule
+ add_config
+ set_subconf
+
+ expand_list
+ new_repos
+ new_repo
+ new_wild_repo
+ hook_repos
+ store
+ parse_done
+);
+
+use Exporter 'import';
+use Data::Dumper;
+$Data::Dumper::Indent = 1;
+$Data::Dumper::Sortkeys = 1;
+
+use Gitolite::Rc;
+use Gitolite::Common;
+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 $nextseq = 0;
+my %ignored;
+
+# ----------------------------------------------------------------------
+
+sub add_to_group {
+ my ( $lhs, @rhs ) = @_;
+ _die "bad group '$lhs'" unless $lhs =~ $REPONAME_PATT;
+ map { _die "bad expansion '$_'" unless $_ =~ $REPOPATT_PATT } @rhs;
+
+ # 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 set_repolist {
+ my @in = @_;
+ @repolist = ();
+ # ...sanity checks
+ while (@in) {
+ $_ = shift @in;
+ if ( check_subconf_repo_disallowed( $subconf, $_ ) ) {
+ if ( exists $groups{$_} ) {
+ # groupname disallowed; try individual members now
+ ( my $g = $_ ) =~ s/^\@$subconf\./\@/;
+ _warn "expanding '$g'; this *may* slow down compilation";
+ unshift @in, keys %{ $groups{$_} };
+ next;
+ }
+ $ignored{$subconf}{$_} = 1;
+ next;
+ }
+
+ _warn "explicit '.git' extension ignored for $_.git" if s/\.git$//;
+ _die "bad reponame '$_'" if $_ !~ $REPOPATT_PATT;
+
+ push @repolist, $_;
+ }
+}
+
+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 "VREF/";
+ # prefix them with "refs/heads/"
+ @refs = map { m(^(refs|VREF)/) or s(^)(refs/heads/); $_ } @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, $fname, $lnum ) = @_;
+ _warn "doesn't make sense to supply a ref ('$ref') for 'R' rule"
+ if $perm eq 'R' and $ref ne 'refs/.*';
+ _warn "possible undeclared group '$user'"
+ if $user =~ /^@/
+ and not $groups{$user}
+ and not $rc{GROUPLIST_PGM}
+ and not special_group($user);
+ _die "bad ref '$ref'" unless $ref =~ $REPOPATT_PATT;
+ _die "bad user '$user'" unless $user =~ $USERNAME_PATT;
+
+ $nextseq++;
+ store_rule_info( $nextseq, $fname, $lnum );
+ for my $repo (@repolist) {
+ push @{ $repos{$repo}{$user} }, [ $nextseq, $perm, $ref ];
+ }
+
+ sub special_group {
+ # ok perl doesn't really have lexical subs (at least not the older
+ # perls I want to support) but let's pretend...
+ my $g = shift;
+ $g =~ s/^\@//;
+ return 1 if $g eq 'all' or $g eq 'CREATOR';
+ return 1 if $rc{ROLES}{$g};
+ return 0;
+ }
+
+}
+
+sub add_config {
+ my ( $n, $key, $value ) = @_;
+
+ $nextseq++;
+ for my $repo (@repolist) {
+ push @{ $configs{$repo} }, [ $nextseq, $key, $value ];
+ }
+}
+
+sub set_subconf {
+ $subconf = shift;
+ _die "bad subconf '$subconf'" unless $subconf =~ /^[-\w.]+$/;
+}
+
+# ----------------------------------------------------------------------
+
+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 new_repos {
+ trace(3);
+ _chdir( $rc{GL_REPO_BASE} );
+
+ # normal repos
+ my @repos = grep { $_ =~ $REPONAME_PATT and not /^@/ } ( sort keys %repos, sort keys %configs );
+ # add in members of repo groups
+ map { push @repos, keys %{ $groups{$_} } } grep { /^@/ and $_ ne '@all' } 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
+
+ # use gl-conf as a sentinel; if it exists, all is well
+ next if -f "$repo.git/gl-conf";
+
+ if (-d "$repo.git") {
+ # directory exists but sentinel missing? Maybe a freshly imported repo?
+ hook_1($repo);
+ } else {
+ push @{ $rc{NEW_REPOS_CREATED} }, $repo;
+ trigger( 'PRE_CREATE', $repo );
+ new_repo($repo);
+ }
+ }
+}
+
+sub new_repo {
+ my $repo = shift;
+ trace( 3, $repo );
+
+ _mkdir("$repo.git");
+ _chdir("$repo.git");
+ _system("git init --bare >&2");
+ _chdir( $rc{GL_REPO_BASE} );
+ hook_1($repo);
+}
+
+sub new_wild_repo {
+ my ( $repo, $user, $aa ) = @_;
+ _chdir( $rc{GL_REPO_BASE} );
+
+ trigger( 'PRE_CREATE', $repo, $user, $aa );
+ new_repo($repo);
+ _print( "$repo.git/gl-creator", $user );
+ trigger( 'POST_CREATE', $repo, $user, $aa );
+
+ _chdir( $rc{GL_ADMIN_BASE} );
+}
+
+sub hook_repos {
+ trace(3);
+
+ # all repos, all hooks
+ _chdir( $rc{GL_REPO_BASE} );
+ my $phy_repos = list_phy_repos(1);
+
+ for my $repo ( @{$phy_repos} ) {
+ hook_1($repo);
+ }
+}
+
+sub store {
+ trace(3);
+
+ # first write out the ones for the physical repos
+ _chdir( $rc{GL_REPO_BASE} );
+
+ # list of repos (union of keys of %repos plus %configs)
+ my %kr_kc;
+ @kr_kc{ keys %repos } = ();
+ @kr_kc{ keys %configs } = ();
+ for my $repo ( keys %kr_kc ) {
+ store_1($repo);
+ }
+
+ _chdir( $rc{GL_ADMIN_BASE} );
+ store_common();
+}
+
+sub parse_done {
+ for my $ig ( sort keys %ignored ) {
+ _warn "subconf '$ig' attempting to set access for " . join( ", ", sort keys %{ $ignored{$ig} } );
+ }
+
+ close_rule_info();
+}
+
+# ----------------------------------------------------------------------
+
+sub check_subconf_repo_disallowed {
+ # trying to set access for $repo (='foo')...
+ my ( $subconf, $repo ) = @_;
+ trace( 2, $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( 2, "-> disallowed" );
+ return 1;
+}
+
+sub store_1 {
+ # warning: writes and *deletes* it from %repos and %configs
+ my ($repo) = shift;
+ trace( 3, $repo );
+ return unless -d "$repo.git";
+
+ my ( %one_repo, %one_config );
+
+ my $dumped_data = '';
+ if ( $repos{$repo} ) {
+ $one_repo{$repo} = $repos{$repo};
+ delete $repos{$repo};
+ $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)] );
+ }
+
+ _print( "$repo.git/gl-conf", $dumped_data );
+
+ $split_conf{$repo} = 1;
+}
+
+sub store_common {
+ trace(3);
+ my $cc = "conf/gitolite.conf-compiled.pm";
+ my $compiled_fh = _open( ">", "$cc.new" );
+
+ my %patterns = ();
+
+ my $data_version = glrc('current-data-version');
+ trace( 3, "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;
+
+ print $compiled_fh $dumped_data;
+
+ if (%groups) {
+ my %groups = %{ inside_out( \%groups ) };
+ $dumped_data = Data::Dumper->Dump( [ \%groups ], [qw(*groups)] );
+ print $compiled_fh $dumped_data;
+
+ # save patterns in %groups for faster handling of multiple repos, such
+ # as happens in the various POST_COMPILE scripts
+ for my $k ( keys %groups ) {
+ $patterns{groups}{$k} = 1 unless $k =~ $REPONAME_PATT;
+ }
+ }
+
+ print $compiled_fh Data::Dumper->Dump( [ \%patterns ], [qw(*patterns)] ) if %patterns;
+
+ 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( 3, $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-defined (custom) hooks to all repos
+ ln_sf( "$rc{LOCAL_CODE}/hooks/common", "*", "$repo.git/hooks" ) if $rc{LOCAL_CODE};
+
+ # override/propagate gitolite defined hooks for all repos
+ ln_sf( "$rc{GL_ADMIN_BASE}/hooks/common", "*", "$repo.git/hooks" );
+ # override/propagate gitolite defined hooks for the admin repo
+ ln_sf( "$rc{GL_ADMIN_BASE}/hooks/gitolite-admin", "*", "$repo.git/hooks" ) if $repo eq 'gitolite-admin';
+ }
+}
+
+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' ]);
+}
+
+{
+ my $ri_fh = '';
+
+ sub store_rule_info {
+ $ri_fh = _open( ">", $rc{GL_ADMIN_BASE} . "/conf/rule_info" ) unless $ri_fh;
+ # $nextseq, $fname, $lnum
+ print $ri_fh join( "\t", @_ ) . "\n";
+ }
+
+ sub close_rule_info {
+ close $ri_fh or die "close rule_info file failed: $!";
+ }
+}
+
+1;
+
diff --git a/src/lib/Gitolite/Conf/Sugar.pm b/src/lib/Gitolite/Conf/Sugar.pm
new file mode 100644
index 0000000..5c743d3
--- /dev/null
+++ b/src/lib/Gitolite/Conf/Sugar.pm
@@ -0,0 +1,202 @@
+# and now for something completely different...
+
+package SugarBox;
+
+sub run_sugar_script {
+ my ( $ss, $lref ) = @_;
+ do $ss if -r $ss;
+ $lref = sugar_script($lref);
+ return $lref;
+}
+
+# ----------------------------------------------------------------------
+
+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} } ) {
+
+ # perl-ism; apart from keeping the full path separate from the
+ # simple name, this also protects %rc from change by implicit
+ # aliasing, which would happen if you touched $s itself
+ my $sfp = _which( "syntactic-sugar/$s", 'r' );
+
+ _warn("skipped sugar script '$s'"), next if not -r $sfp;
+ $lines = SugarBox::run_sugar_script( $sfp, $lines );
+ $lines = [ grep /\S/, map { cleanup_conf_line($_) } @$lines ];
+ }
+ }
+ }
+
+ # then our stuff:
+
+ $lines = rw_cdm($lines);
+ $lines = option($lines); # must come after rw_cdm
+ $lines = owner_desc($lines);
+ $lines = name_vref($lines);
+ $lines = role_names($lines);
+ $lines = skip_block($lines);
+
+ return $lines;
+}
+
+sub rw_cdm {
+ my $lines = shift;
+ my @ret;
+
+ # repo foo <...> RWC = ...
+ # -> option CREATE_IS_C = 1
+ # (and similarly DELETE_IS_D and MERGE_CHECK)
+ # but only once per repo of course
+
+ my %seen = ();
+ for my $line (@$lines) {
+ push @ret, $line;
+ if ( $line =~ /^repo / ) {
+ %seen = ();
+ } elsif ( $line =~ /^(-|C|R|RW\+?(?:C?D?|D?C?)M?) (.* )?= (.+)/ ) {
+ my $perms = $1;
+ push @ret, "option DELETE_IS_D = 1" if $perms =~ /D/ and not $seen{D}++;
+ push @ret, "option CREATE_IS_C = 1" if $perms =~ /RW.*C/ and not $seen{C}++;
+ push @ret, "option MERGE_CHECK = 1" if $perms =~ /M/ and not $seen{M}++;
+ }
+ }
+ return \@ret;
+}
+
+sub option {
+ my $lines = shift;
+ my @ret;
+
+ # option foo = bar
+ # -> config gitolite-options.foo = bar
+
+ for my $line (@$lines) {
+ $line =~ s/option mirror\.slaves/option mirror.copies/;
+ if ( $line =~ /^option (\S+) = (\S.*)/ ) {
+ push @ret, "config gitolite-options.$1 = $2";
+ } else {
+ push @ret, $line;
+ }
+ }
+ return \@ret;
+}
+
+sub owner_desc {
+ my $lines = shift;
+ my @ret;
+
+ # owner = "owner name"
+ # -> config gitweb.owner = owner name
+ # desc = "some long description"
+ # -> config gitweb.description = some long description
+ # category = "whatever..."
+ # -> config gitweb.category = whatever...
+
+ for my $line (@$lines) {
+ if ( $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;
+}
+
+sub name_vref {
+ my $lines = shift;
+ my @ret;
+
+ # <perm> NAME/foo = <user>
+ # -> <perm> VREF/NAME/foo = <user>
+
+ for my $line (@$lines) {
+ if ( $line =~ /^(-|R\S+) \S.* = \S.*/ ) {
+ $line =~ s( NAME/)( VREF/NAME/)g;
+ }
+ push @ret, $line;
+ }
+ return \@ret;
+}
+
+sub role_names {
+ my $lines = shift;
+ my @ret;
+
+ # <perm> [<ref>] = <user list containing CREATOR|READERS|WRITERS>
+ # -> same but with "@" prepended to rolenames
+
+ for my $line (@$lines) {
+ if ( $line =~ /^(-|C|R|RW\+?(?:C?D?|D?C?)M?) (.* )?= (.+)/ ) {
+ my ( $p, $r ) = ( $1, $2 );
+ my $u = '';
+ for ( split ' ', $3 ) {
+ $_ = "\@$_" if $_ eq 'CREATOR' or $rc{ROLES}{$_};
+ $u .= " $_";
+ }
+ $r ||= '';
+ # mind the spaces (or play safe and run cleanup_conf_line again)
+ push @ret, cleanup_conf_line("$p $r = $u");
+ } else {
+ push @ret, $line;
+ }
+ }
+ return \@ret;
+}
+
+sub skip_block {
+ my $lines = shift;
+
+ my @out = ();
+ for (@$lines) {
+ my $skip = 0;
+ $skip = 1 if /^= *begin testconf$/;
+ $skip = 1 if /^= *begin template-data$/;
+ # add code for other types of blocks here as needed
+
+ next if $skip .. /^= *end$/;
+ push @out, $_;
+ }
+
+ return \@out;
+}
+
+1;
+
diff --git a/src/lib/Gitolite/Easy.pm b/src/lib/Gitolite/Easy.pm
new file mode 100644
index 0000000..8f530f2
--- /dev/null
+++ b/src/lib/Gitolite/Easy.pm
@@ -0,0 +1,240 @@
+package Gitolite::Easy;
+
+# easy access to gitolite from external perl programs
+# ----------------------------------------------------------------------
+# most/all functions in this module test $ENV{GL_USER}'s rights and
+# permissions so it needs to be set.
+
+# "use"-ing this module
+# ----------------------------------------------------------------------
+# Using this module from within a gitolite trigger or command is easy; you
+# just need 'use lib $ENV{GL_LIBDIR};' before the 'use Gitolite::Easy;'.
+#
+# Using it from something completely outside gitolite requires a bit more
+# work. First, run 'gitolite query-rc -a' to find the correct values for
+# GL_BINDIR and GL_LIBDIR in your installation. Then use this code in your
+# external program, using the paths you just found:
+#
+# BEGIN {
+# $ENV{HOME} = "/home/git"; # or whatever is the hosting user's $HOME
+# $ENV{GL_BINDIR} = "/full/path/to/gitolite/src";
+# $ENV{GL_LIBDIR} = "/full/path/to/gitolite/src/lib";
+# }
+# use lib $ENV{GL_LIBDIR};
+# use Gitolite::Easy;
+
+# API documentation
+# ----------------------------------------------------------------------
+# documentation for each function is at the top of the function.
+# Documentation is NOT in pod format; just read the source with a nice syntax
+# coloring text editor and you'll be happy enough. (I do not like POD; please
+# don't send me patches for this aspect of the module).
+
+#<<<
+@EXPORT = qw(
+ is_admin
+ is_super_admin
+ in_group
+ in_role
+
+ owns
+ can_read
+ can_write
+
+ config
+
+ textfile
+
+ %rc
+ say
+ say2
+ _die
+ _warn
+ _print
+ usage
+
+ option
+);
+#>>>
+use Exporter 'import';
+
+use Gitolite::Rc;
+use Gitolite::Common;
+use Gitolite::Conf::Load;
+
+use strict;
+use warnings;
+
+my $user;
+
+# ----------------------------------------------------------------------
+
+# is_admin()
+
+# return true if $ENV{GL_USER} is set and has W perms to the admin repo
+
+# shell equivalent
+# if gitolite access -q gitolite-admin $GL_USER W; then ...
+
+sub is_admin {
+ valid_user();
+ return not( access( 'gitolite-admin', $user, 'W', 'any' ) =~ /DENIED/ );
+}
+
+# is_super_admin()
+
+# (useful only if you are using delegation)
+
+# return true if $ENV{GL_USER} is set and has W perms to any file in the admin
+# repo
+
+# shell equivalent
+# if gitolite access -q gitolite-admin $GL_USER W VREF/NAME/; then ...
+sub is_super_admin {
+ valid_user();
+ return not( access( 'gitolite-admin', $user, 'W', 'VREF/NAME/' ) =~ /DENIED/ );
+}
+
+# in_group()
+
+# return true if $ENV{GL_USER} is set and is in the given group
+
+# shell equivalent
+# if gitolite list-memberships $GL_USER | grep -x $GROUPNAME >/dev/null; then ...
+sub in_group {
+ valid_user();
+ my $g = shift;
+ $g =~ s/^\@?/@/;
+
+ return grep { $_ eq $g } @{ Gitolite::Conf::Load::list_memberships( '-u', $user ) };
+}
+
+# in_role()
+
+# return true if $ENV{GL_USER} is set and has the given role for the given repo
+
+# shell equivalent
+# if gitolite list-memberships -u $GL_USER -r $GL_REPO | grep -x $ROLENAME >/dev/null; then ...
+sub in_role {
+ valid_user();
+ my $r = shift;
+ $r =~ s/^\@?/@/;
+ my $repo = shift;
+
+ return grep { $_ eq $r } @{ Gitolite::Conf::Load::list_memberships( "-u", $user, "-r", $repo ) };
+}
+
+# owns()
+
+# return true if $ENV{GL_USER} is set and is an OWNER of the given repo.
+
+# shell equivalent (assuming GL_USER is set)
+# if gitolite owns $REPONAME; then ...
+sub owns {
+ valid_user();
+ my $r = shift;
+
+ # prevent unnecessary disclosure of repo existence info
+ return 0 if repo_missing($r);
+
+ return ( creator($r) eq $user or $rc{OWNER_ROLENAME} and in_role( $rc{OWNER_ROLENAME}, $r ) );
+}
+
+# can_read()
+# return true if $ENV{GL_USER} is set and can read the given repo
+
+# shell equivalent
+# if gitolite access -q $REPONAME $GL_USER R; then ...
+sub can_read {
+ valid_user();
+ my $r = shift;
+ return not( access( $r, $user, 'R', 'any' ) =~ /DENIED/ );
+}
+
+# can_write()
+# return true if $ENV{GL_USER} is set and can write to the given repo.
+# Optional second argument can be '+' to check that instead of 'W'. Optional
+# third argument can be a full ref name instead of 'any'.
+
+# shell equivalent
+# if gitolite access -q $REPONAME $GL_USER W; then ...
+sub can_write {
+ valid_user();
+ my ( $r, $aa, $ref ) = @_;
+ $aa ||= 'W';
+ $ref ||= 'any';
+ return not( access( $r, $user, $aa, $ref ) =~ /DENIED/ );
+}
+
+# config()
+# given a repo and a key, return a hash containing all the git config
+# variables for that repo where the section+key match the regex. If none are
+# found, return an empty hash. If you don't want it as a regex, use \Q
+# appropriately
+
+# shell equivalent
+# foo=$(gitolite git-config -r $REPONAME foo\\.bar)
+sub config {
+ my $repo = shift;
+ my $key = shift;
+
+ return () if repo_missing($repo);
+
+ my $ret = git_config( $repo, $key );
+ return %$ret;
+}
+
+# ----------------------------------------------------------------------
+
+# maintain a textfile; see comments in code for details, and calls in various
+# other programs (like 'motd', 'desc', and 'readme') for how to call
+sub textfile {
+ my %h = @_;
+ my $repodir;
+
+ # target file
+ _die "need file" unless $h{file};
+ _die "'$h{file}' contains a '/'" if $h{file} =~ m(/);
+ Gitolite::Conf::Load::sanity($h{file}, $REPONAME_PATT);
+
+ # target file's location. This can come from one of two places: dir
+ # (which comes from our code, so does not need to be sanitised), or repo,
+ # which may come from the user
+ _die "need exactly one of repo or dir" unless $h{repo} xor $h{dir};
+ _die "'$h{dir}' does not exist" if $h{dir} and not -d $h{dir};
+ if ($h{repo}) {
+ Gitolite::Conf::Load::sanity($h{repo}, $REPONAME_PATT);
+ $h{dir} = "$rc{GL_REPO_BASE}/$h{repo}.git";
+ _die "repo '$h{repo}' does not exist" if not -d $h{dir};
+
+ my $umask = option( $h{repo}, 'umask' );
+ # note: using option() moves us to ADMIN_BASE, but we don't care here
+ umask oct($umask) if $umask;
+ }
+
+ # final full file name
+ my $f = "$h{dir}/$h{file}";
+
+ # operation
+ _die "can't have both prompt and text" if defined $h{prompt} and defined $h{text};
+ if (defined $h{prompt}) {
+ print STDERR $h{prompt};
+ my $t = join( "", <> );
+ _print($f, $t);
+ } elsif (defined $h{text}) {
+ _print($f, $h{text});
+ } else {
+ return slurp($f) if -f $f;
+ }
+
+ return '';
+}
+
+# ----------------------------------------------------------------------
+
+sub valid_user {
+ _die "GL_USER not set" unless exists $ENV{GL_USER};
+ $user = $ENV{GL_USER};
+}
+
+1;
diff --git a/src/lib/Gitolite/Hooks/PostUpdate.pm b/src/lib/Gitolite/Hooks/PostUpdate.pm
new file mode 100644
index 0000000..a76d1d9
--- /dev/null
+++ b/src/lib/Gitolite/Hooks/PostUpdate.pm
@@ -0,0 +1,75 @@
+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, 'post-up', @ARGV );
+ exit 0 unless grep( m(^refs/heads/master$), @ARGV );
+ # 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)$/m;
+
+ my $hooks_changed = 0;
+ {
+ local $ENV{GIT_WORK_TREE} = $rc{GL_ADMIN_BASE};
+
+ tsh_try("git diff --name-only master");
+ $hooks_changed++ if tsh_text() =~ m(/hooks/common/);
+ # the leading slash ensure that this hooks/common directory is below
+ # some top level directory, not *at* the top. That's LOCAL_CODE, and
+ # it's actual name could be anything but it doesn't matter to us.
+
+ tsh_try("git checkout -f --quiet master");
+ }
+ _system("gitolite compile");
+ _system("gitolite setup --hooks-only") if $hooks_changed;
+ _system("gitolite trigger POST_COMPILE");
+
+ exit 0;
+}
+
+{
+ my $text = '';
+
+ sub post_update_hook {
+ if ( not $text ) {
+ local $/ = undef;
+ $text = <DATA>;
+ }
+ return $text;
+ }
+}
+
+1;
+
+__DATA__
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use lib $ENV{GL_LIBDIR};
+use Gitolite::Hooks::PostUpdate;
+
+# gitolite post-update hook (only for the admin repo)
+# ----------------------------------------------------------------------
+
+post_update(); # is not expected to return
+exit 1; # so if it does, something is wrong
diff --git a/src/lib/Gitolite/Hooks/Update.pm b/src/lib/Gitolite/Hooks/Update.pm
new file mode 100644
index 0000000..2bc43a8
--- /dev/null
+++ b/src/lib/Gitolite/Hooks/Update.pm
@@ -0,0 +1,172 @@
+package Gitolite::Hooks::Update;
+
+# everything to do with the update hook
+# ----------------------------------------------------------------------
+
+@EXPORT = qw(
+ update
+ update_hook
+);
+
+use Exporter 'import';
+
+use Gitolite::Rc;
+use Gitolite::Common;
+use Gitolite::Conf::Load;
+
+use strict;
+use warnings;
+
+$|++;
+
+# ----------------------------------------------------------------------
+
+sub update {
+ # this is the *real* update hook for gitolite
+
+ bypass() if $ENV{GL_BYPASS_ACCESS_CHECKS};
+
+ my ( $ref, $oldsha, $newsha, $oldtree, $newtree, $aa ) = args(@ARGV);
+
+ trace( 2, $ENV{GL_REPO}, $ENV{GL_USER}, $aa, @ARGV );
+
+ my $ret = access( $ENV{GL_REPO}, $ENV{GL_USER}, $aa, $ref );
+ trigger( 'ACCESS_2', $ENV{GL_REPO}, $ENV{GL_USER}, $aa, $ref, $ret, $oldsha, $newsha );
+ _die $ret if $ret =~ /DENIED/;
+
+ check_vrefs( $ref, $oldsha, $newsha, $oldtree, $newtree, $aa );
+
+ gl_log( 'update', $ENV{GL_REPO}, $ENV{GL_USER}, $aa, @ARGV, $ret );
+ exit 0;
+}
+
+sub bypass {
+ require Cwd;
+ Cwd->import;
+ gl_log( 'update', getcwd(), '(' . ( $ENV{USER} || '?' ) . ')', 'bypass', @ARGV );
+ exit 0;
+}
+
+sub check_vrefs {
+ my ( $ref, $oldsha, $newsha, $oldtree, $newtree, $aa ) = @_;
+ my $name_seen = 0;
+ my $n_vrefs = 0;
+ for my $vref ( vrefs( $ENV{GL_REPO}, $ENV{GL_USER} ) ) {
+ $n_vrefs++;
+ if ( $vref =~ m(^VREF/NAME/) ) {
+ # this one is special; we process it right here, and only once
+ next if $name_seen++;
+
+ for my $ref ( map { chomp; s(^)(VREF/NAME/); $_; } `git diff --name-only $oldtree $newtree` ) {
+ check_vref( $aa, $ref );
+ }
+ } else {
+ my ( $dummy, $pgm, @args ) = split '/', $vref;
+ $pgm = _which( "VREF/$pgm", 'x' );
+ $pgm or _die "'$vref': helper program missing or unexecutable";
+
+ open( my $fh, "-|", $pgm, @_, $vref, @args ) or _die "'$vref': can't spawn helper program: $!";
+ while (<$fh>) {
+ # print non-vref lines and skip processing (for example,
+ # normal STDOUT by a normal update hook)
+ unless (m(^VREF/)) {
+ print;
+ next;
+ }
+ my ( $ref, $deny_message ) = split( ' ', $_, 2 );
+ check_vref( $aa, $ref, $deny_message );
+ }
+ close($fh) or _die $!
+ ? "Error closing sort pipe: $!"
+ : "$vref: helper program exit status $?";
+ }
+ }
+ return $n_vrefs;
+}
+
+sub check_vref {
+ my ( $aa, $ref, $deny_message ) = @_;
+
+ my $ret = access( $ENV{GL_REPO}, $ENV{GL_USER}, $aa, $ref );
+ trace( 2, "access($ENV{GL_REPO}, $ENV{GL_USER}, $aa, $ref)", "-> $ret" );
+ if ( $ret =~ /by fallthru/ ) {
+ trace( 3, "remember, fallthru is success here!" );
+ return;
+ }
+ trigger( 'ACCESS_2', $ENV{GL_REPO}, $ENV{GL_USER}, $aa, $ref, $ret );
+ _die "$ret" . ( $deny_message ? "\n$deny_message" : '' ) if $ret =~ /DENIED/;
+}
+
+{
+ my $text = '';
+
+ sub update_hook {
+ 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;
+
+ $aa = 'D' if ( option( $ENV{GL_REPO}, 'DELETE_IS_D' ) ) and $newsha eq '0' x 40;
+ $aa = 'C' if ( option( $ENV{GL_REPO}, 'CREATE_IS_C' ) ) and $oldsha eq '0' x 40;
+
+ # and now "M" commits. 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)
+
+ if ( option( $ENV{GL_REPO}, '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` =~ /./;
+ }
+ }
+
+ return ( $ref, $oldsha, $newsha, $oldtree, $newtree, $aa );
+}
+
+1;
+
+__DATA__
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use lib $ENV{GL_LIBDIR};
+use Gitolite::Hooks::Update;
+
+# gitolite update hook
+# ----------------------------------------------------------------------
+
+update(); # is not expected to return
+exit 1; # so if it does, something is wrong
diff --git a/src/lib/Gitolite/Rc.pm b/src/lib/Gitolite/Rc.pm
new file mode 100644
index 0000000..41996fb
--- /dev/null
+++ b/src/lib/Gitolite/Rc.pm
@@ -0,0 +1,688 @@
+package Gitolite::Rc;
+
+# everything to do with 'rc'. Also defines some 'constants'
+# ----------------------------------------------------------------------
+
+@EXPORT = qw(
+ %rc
+ glrc
+ query_rc
+ version
+ greeting
+ trigger
+ _which
+
+ $REMOTE_COMMAND_PATT
+ $REF_OR_FILENAME_PATT
+ $REPONAME_PATT
+ $REPOPATT_PATT
+ $USERNAME_PATT
+ $UNSAFE_PATT
+);
+
+use Exporter 'import';
+
+use Gitolite::Common;
+
+# ----------------------------------------------------------------------
+
+our %rc;
+our $non_core;
+
+# ----------------------------------------------------------------------
+
+# pre-populate some important rc keys
+# ----------------------------------------------------------------------
+
+$rc{GL_BINDIR} = $ENV{GL_BINDIR};
+$rc{GL_LIBDIR} = $ENV{GL_LIBDIR};
+
+# these keys could be overridden by the rc file later
+$rc{GL_REPO_BASE} = "$ENV{HOME}/repositories";
+$rc{GL_ADMIN_BASE} = "$ENV{HOME}/.gitolite";
+$rc{LOG_TEMPLATE} = "$ENV{HOME}/.gitolite/logs/gitolite-%y-%m.log";
+
+# variables that should probably never be changed but someone will want to, I'll bet...
+# ----------------------------------------------------------------------
+
+#<<<
+$REMOTE_COMMAND_PATT = qr(^[-0-9a-zA-Z._\@/+ :,\%=]*$);
+$REF_OR_FILENAME_PATT = qr(^[0-9a-zA-Z][-0-9a-zA-Z._\@/+ :,]*$);
+$REPONAME_PATT = qr(^\@?[0-9a-zA-Z][-0-9a-zA-Z._\@/+]*$);
+$REPOPATT_PATT = qr(^\@?[[0-9a-zA-Z][-0-9a-zA-Z._\@/+\\^$|()[\]*?{},]*$);
+$USERNAME_PATT = qr(^\@?[0-9a-zA-Z][-0-9a-zA-Z._\@+]*$);
+
+$UNSAFE_PATT = qr([`~#\$\&()|;<>]);
+#>>>
+
+# ----------------------------------------------------------------------
+
+# find the rc file and 'do' it
+# ----------------------------------------------------------------------
+my $current_data_version = "3.2";
+
+my $rc = glrc('filename');
+if ( -r $rc and -s $rc ) {
+ do $rc or die $@;
+}
+if ( defined($GL_ADMINDIR) ) {
+ say2 "";
+ say2 "FATAL: '$rc' seems to be for older gitolite; please see\nhttp://gitolite.com/gitolite/migr.html";
+
+ exit 1;
+}
+
+# let values specified in rc file override our internal ones
+# ----------------------------------------------------------------------
+@rc{ keys %RC } = values %RC;
+
+# expand the non_core list into INPUT, PRE_GIT, etc using 'ENABLE' settings
+non_core_expand() if $rc{ENABLE};
+
+# add internal triggers
+# ----------------------------------------------------------------------
+
+# is the server/repo in a writable state (i.e., not down for maintenance etc)
+unshift @{ $rc{ACCESS_1} }, 'Writable::access_1';
+
+# (testing only) override the rc file 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};
+
+# setup some perl/rc/env vars, plus umask
+# ----------------------------------------------------------------------
+
+umask ( $rc{UMASK} || 0077 );
+
+unshift @INC, "$rc{LOCAL_CODE}/lib" if $rc{LOCAL_CODE};
+
+$ENV{PATH} = "$ENV{GL_BINDIR}:$ENV{PATH}" unless $ENV{PATH} =~ /^$ENV{GL_BINDIR}:/;
+
+{
+ $rc{GL_TID} = $ENV{GL_TID} ||= $$;
+ # TID: loosely, transaction ID. The first PID at the entry point passes
+ # it down to all its children so you can track each access, across all the
+ # various commands it spawns and actions it generates.
+
+ $rc{GL_LOGFILE} = $ENV{GL_LOGFILE} ||= gen_lfn( $rc{LOG_TEMPLATE} );
+}
+
+# these two are meant to help externally written commands (see
+# src/commands/writable for an example)
+$ENV{GL_REPO_BASE} = $rc{GL_REPO_BASE};
+$ENV{GL_ADMIN_BASE} = $rc{GL_ADMIN_BASE};
+
+# ----------------------------------------------------------------------
+
+use strict;
+use warnings;
+
+# ----------------------------------------------------------------------
+
+my $glrc_default_text = '';
+{
+ local $/ = undef;
+ $glrc_default_text = <DATA>;
+}
+
+# ----------------------------------------------------------------------
+
+sub non_core_expand {
+ my %enable;
+
+ for my $e ( @{ $rc{ENABLE} } ) {
+ my ( $name, $arg ) = split ' ', $e, 2;
+ # store args as the hash value for the name
+ $enable{$name} = $arg || '';
+
+ # for now, we pretend everything is a command, because commands
+ # are the only thing that the non_core list does not contain
+ $rc{COMMANDS}{$name} = $arg || 1;
+ }
+
+ # bring in additional non-core specs from the rc file, if given
+ if ( my $nc2 = $rc{NON_CORE} ) {
+ for ( $non_core, $nc2 ) {
+ # beat 'em into shape :)
+ s/#.*//g;
+ s/[ \t]+/ /g; s/^ //mg; s/ $//mg;
+ s/\n+/\n/g;
+ }
+
+ for ( split "\n", $nc2 ) {
+ next unless /\S/;
+ my ( $name, $where, $module, $before, $name2 ) = split ' ', $_;
+ if ( not $before ) {
+ $non_core .= "$name $where $module\n";
+ next;
+ }
+ die if $before ne 'before';
+ $non_core =~ s(^(?=$name2 $where( |$)))($name $where $module\n)m;
+ }
+ }
+
+ my @data = split "\n", $non_core || '';
+ for (@data) {
+ next if /^\s*(#|$)/;
+ my ( $name, $where, $module ) = split ' ', $_;
+
+ # if it appears here, it's not a command, so delete it. At the end of
+ # this loop, what's left in $rc{COMMANDS} will be those names in the
+ # enable list that do not appear in the non_core list.
+ delete $rc{COMMANDS}{$name};
+
+ next unless exists $enable{$name};
+
+ # module to call is name if specified as "."
+ $module = $name if $module eq ".";
+
+ # module to call is "name::pre_git" or such if specified as "::"
+ ( $module = $name ) .= "::" . lc($where) if $module eq '::';
+
+ # append arguments, if supplied
+ $module .= " $enable{$name}" if $enable{$name};
+
+ push @{ $rc{$where} }, $module;
+ }
+
+ # finally, add in commands that were declared in the non-core list
+ map { /^(\S+)/; $rc{COMMANDS}{$1} = 1 } @{ $rc{COMMAND} };
+}
+
+# exported functions
+# ----------------------------------------------------------------------
+
+sub glrc {
+ my $cmd = shift;
+ if ( $cmd eq 'default-filename' ) {
+ return "$ENV{HOME}/.gitolite.rc";
+ } elsif ( $cmd eq 'default-text' ) {
+ 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?
+
+ # search $HOME first
+ return "$ENV{HOME}/.gitolite.rc" if -f "$ENV{HOME}/.gitolite.rc";
+
+ return '';
+ } elsif ( $cmd eq 'current-data-version' ) {
+ return $current_data_version;
+ } else {
+ _die "unknown argument to glrc: '$cmd'";
+ }
+}
+
+my $all = 0;
+my $dump = 0;
+my $nonl = 0;
+my $quiet = 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";
+ }
+ exit 0;
+ }
+
+ if ($dump) {
+ require Data::Dumper;
+ $Data::Dumper::Sortkeys = 1;
+ print Data::Dumper::Dumper \%rc;
+ exit 0;
+ }
+
+ my $cv = \%rc; # current "value"
+ while (@vars) {
+ my $v = shift @vars;
+
+ # dig into the rc hash, using each var as a component
+ if ( not ref($cv) ) {
+ _warn "unused arguments...";
+ last;
+ } elsif ( ref($cv) eq 'HASH' ) {
+ $cv = $cv->{$v} || '';
+ } elsif ( ref($cv) eq 'ARRAY' ) {
+ $cv = $cv->[$v] || '';
+ } else {
+ _die "dont know what to do with " . ref($cv) . " item in the rc file";
+ }
+ }
+
+ # we've run out of arguments so $cv is what we have. If we're supposed to
+ # be quiet, we don't have to print anything so let's get that done first:
+ exit( $cv ? 0 : 1 ) if $quiet; # shell truth
+
+ # print values (notice we ignore the '-n' option if it's a ref)
+ if ( ref($cv) eq 'HASH' ) {
+ print join( "\n", sort keys %$cv ), "\n" if %$cv;
+ } elsif ( ref($cv) eq 'ARRAY' ) {
+ print join( "\n", @$cv ), "\n" if @$cv;
+ } else {
+ print $cv . ( $nonl ? '' : "\n" ) if $cv;
+ }
+ exit( $cv ? 0 : 1 ); # shell truth
+}
+
+sub version {
+ my $version = '';
+ $version = '(unknown)';
+ for ("$ENV{GL_BINDIR}/VERSION") {
+ $version = slurp($_) if -r $_;
+ }
+ chomp($version);
+ return $version;
+}
+
+sub greeting {
+ my $json = shift;
+
+ chomp( my $hn = `hostname -s 2>/dev/null || hostname` );
+ my $gv = substr( `git --version`, 12 );
+ my $gl_user = $ENV{GL_USER} || '';
+ $gl_user = " $gl_user" if $gl_user;
+
+ if ($json) {
+ $json->{GL_USER} = $ENV{GL_USER};
+ $json->{USER} = ( $ENV{USER} || "httpd" ) . "\@$hn";
+ $json->{gitolite_version} = version();
+ chomp( $json->{git_version} = $gv ); # this thing has a newline at the end
+ return;
+ }
+
+ # normal output
+ return "hello$gl_user, this is " . ( $ENV{USER} || "httpd" ) . "\@$hn running gitolite3 " . version() . " on git $gv\n";
+}
+
+sub trigger {
+ my $rc_section = shift;
+
+ # if arg-2 (now arg-1, due to the 'shift' above) exists, it is a repo
+ # name, so setup env from options
+ require Gitolite::Conf::Load;
+ Gitolite::Conf::Load->import('env_options');
+ env_options( $_[0] ) if $_[0];
+
+ if ( exists $rc{$rc_section} ) {
+ if ( ref( $rc{$rc_section} ) ne 'ARRAY' ) {
+ _die "'$rc_section' section in rc file is not a perl list";
+ } else {
+ for my $s ( @{ $rc{$rc_section} } ) {
+ my ( $pgm, @args ) = split ' ', $s;
+
+ if ( my ( $module, $sub ) = ( $pgm =~ /^(.*)::(\w+)$/ ) ) {
+
+ require Gitolite::Triggers;
+ trace( 2, 'trigger module', $module, $sub, @args, $rc_section, @_ );
+ Gitolite::Triggers::run( $module, $sub, @args, $rc_section, @_ );
+
+ } else {
+ $pgm = _which( "triggers/$pgm", 'x' );
+
+ _warn("skipped trigger '$s' (not found or not executable)"), next if not $pgm;
+ trace( 2, 'trigger command', $s );
+ _system( $pgm, @args, $rc_section, @_ ); # they better all return with 0 exit codes!
+ }
+ }
+ }
+ return;
+ }
+ trace( 3, "'$rc_section' not found in rc" );
+}
+
+sub _which {
+ # looks for a file in LOCAL_CODE or GL_BINDIR. Returns whichever exists
+ # (LOCAL_CODE preferred if defined) or 0 if not found.
+ my $file = shift;
+ my $mode = shift; # could be 'x' or 'r'
+
+ my @files = ("$rc{GL_BINDIR}/$file");
+ unshift @files, ("$rc{LOCAL_CODE}/$file") if $rc{LOCAL_CODE};
+
+ for my $f (@files) {
+ return $f if -x $f;
+ return $f if -r $f and $mode eq 'r';
+ }
+
+ return 0;
+}
+
+# ----------------------------------------------------------------------
+
+=for args
+Usage: gitolite query-rc -a
+ gitolite query-rc -d
+ gitolite query-rc [-n] [-q] rc-variable
+
+ -a print all variables and values (first level only)
+ -d dump the entire rc structure
+ -n do not append a newline if variable is scalar
+ -q exit code only (shell truth; 0 is success)
+
+Query the rc hash. Second and subsequent arguments dig deeper into the hash.
+The examples are for the default configuration; yours may be different.
+
+Single values:
+ gitolite query-rc GL_ADMIN_BASE # prints "/home/git/.gitolite" or similar
+ gitolite query-rc UMASK # prints "63" (that's 0077 in decimal!)
+
+Hashes:
+ gitolite query-rc COMMANDS
+ # prints "desc", "help", "info", "perms", "writable", one per line
+ gitolite query-rc COMMANDS help # prints 1
+ gitolite query-rc -q COMMANDS help # prints nothing; exit code is 0
+ gitolite query-rc COMMANDS fork # prints nothing; exit code is 1
+
+Arrays (somewhat less useful):
+ gitolite query-rc POST_GIT # prints nothing; exit code is 0
+ gitolite query-rc POST_COMPILE # prints 4 lines
+ gitolite query-rc POST_COMPILE 0 # prints the first of those 4 lines
+
+Explore:
+ gitolite query-rc -a
+ # prints all first level variables and values, one per line. Any that are
+ # listed as HASH or ARRAY can be explored further in subsequent commands.
+ gitolite query-rc -d # dump the entire rc structure
+=cut
+
+sub args {
+ my $help = 0;
+
+ require Getopt::Long;
+ Getopt::Long::GetOptions(
+ 'all|a' => \$all,
+ 'dump|d' => \$dump,
+ 'nonl|n' => \$nonl,
+ 'quiet|q' => \$quiet,
+ 'help|h' => \$help,
+ ) or usage();
+
+ _die("'-a' cannot be combined with other arguments or options; run with '-h' for usage") if $all and ( @ARGV or $dump or $nonl or $quiet );
+ usage() if not $all and not $dump and not @ARGV or $help;
+ return @ARGV;
+}
+
+# ----------------------------------------------------------------------
+
+BEGIN {
+ $non_core = "
+ # No user-servicable parts inside. Warranty void if seal broken. Refer
+ # servicing to authorised service center only.
+
+ continuation-lines SYNTACTIC_SUGAR .
+ keysubdirs-as-groups SYNTACTIC_SUGAR .
+ macros SYNTACTIC_SUGAR .
+ refex-expr SYNTACTIC_SUGAR .
+
+ renice PRE_GIT .
+
+ Kindergarten INPUT ::
+
+ CpuTime INPUT ::
+ CpuTime POST_GIT ::
+
+ Shell INPUT ::
+
+ Alias INPUT ::
+
+ Motd INPUT ::
+ Motd PRE_GIT ::
+ Motd COMMAND motd
+
+ Mirroring INPUT ::
+ Mirroring PRE_GIT ::
+ Mirroring POST_GIT ::
+
+ refex-expr ACCESS_2 RefexExpr::access_2
+
+ expand-deny-messages ACCESS_1 .
+ expand-deny-messages ACCESS_2 .
+
+ RepoUmask PRE_GIT ::
+ RepoUmask POST_CREATE ::
+
+ partial-copy PRE_GIT .
+
+ upstream PRE_GIT .
+
+ no-create-on-read PRE_CREATE AutoCreate::deny_R
+ no-auto-create PRE_CREATE AutoCreate::deny_RW
+
+ ssh-authkeys-split POST_COMPILE post-compile/ssh-authkeys-split
+ ssh-authkeys POST_COMPILE post-compile/ssh-authkeys
+ Shell POST_COMPILE post-compile/ssh-authkeys-shell-users
+
+ set-default-roles POST_CREATE .
+
+ git-config POST_COMPILE post-compile/update-git-configs
+ git-config POST_CREATE post-compile/update-git-configs
+
+ create-with-reference POST_CREATE post-compile/create-with-reference
+
+ gitweb POST_CREATE post-compile/update-gitweb-access-list
+ gitweb POST_COMPILE post-compile/update-gitweb-access-list
+
+ cgit POST_COMPILE post-compile/update-description-file
+
+ daemon POST_CREATE post-compile/update-git-daemon-access-list
+ daemon POST_COMPILE post-compile/update-git-daemon-access-list
+
+ repo-specific-hooks POST_COMPILE .
+ repo-specific-hooks POST_CREATE .
+";
+}
+
+1;
+
+# ----------------------------------------------------------------------
+
+__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, use single quotes unless you know what you're doing,
+# and make sure the brackets and braces stay matched up!
+
+# (Tip: perl allows a comma after the last item in a list also!)
+
+# HELP for commands can be had by running the command with "-h".
+
+# HELP for all the other FEATURES can be found in the documentation (look for
+# "list of non-core programs shipped with gitolite" in the master index) or
+# directly in the corresponding source file.
+
+%RC = (
+
+ # ------------------------------------------------------------------
+
+ # default umask gives you perms of '0700'; see the rc file docs for
+ # how/why you might change this
+ UMASK => 0077,
+
+ # look for "git-config" in the documentation
+ GIT_CONFIG_KEYS => '',
+
+ # comment out if you don't need all the extra detail in the logfile
+ LOG_EXTRA => 1,
+ # logging options
+ # 1. leave this section as is for 'normal' gitolite logging (default)
+ # 2. uncomment this line to log ONLY to syslog:
+ # LOG_DEST => 'syslog',
+ # 3. uncomment this line to log to syslog and the normal gitolite log:
+ # LOG_DEST => 'syslog,normal',
+ # 4. prefixing "repo-log," to any of the above will **also** log just the
+ # update records to "gl-log" in the bare repo directory:
+ # LOG_DEST => 'repo-log,normal',
+ # LOG_DEST => 'repo-log,syslog',
+ # LOG_DEST => 'repo-log,syslog,normal',
+ # syslog 'facility': defaults to 'local0', uncomment if needed. For example:
+ # LOG_FACILITY => 'local4',
+
+ # roles. add more roles (like MANAGER, TESTER, ...) here.
+ # WARNING: if you make changes to this hash, you MUST run 'gitolite
+ # compile' afterward, and possibly also 'gitolite trigger POST_COMPILE'
+ ROLES => {
+ READERS => 1,
+ WRITERS => 1,
+ },
+
+ # enable caching (currently only Redis). PLEASE RTFM BEFORE USING!!!
+ # CACHE => 'Redis',
+
+ # ------------------------------------------------------------------
+
+ # rc variables used by various features
+
+ # the 'info' command prints this as additional info, if it is set
+ # SITE_INFO => 'Please see http://blahblah/gitolite for more help',
+
+ # the CpuTime feature uses these
+ # display user, system, and elapsed times to user after each git operation
+ # DISPLAY_CPU_TIME => 1,
+ # display a warning if total CPU times (u, s, cu, cs) crosses this limit
+ # CPU_TIME_WARN_LIMIT => 0.1,
+
+ # the Mirroring feature needs this
+ # HOSTNAME => "foo",
+
+ # TTL for redis cache; PLEASE SEE DOCUMENTATION BEFORE UNCOMMENTING!
+ # CACHE_TTL => 600,
+
+ # ------------------------------------------------------------------
+
+ # suggested locations for site-local gitolite code (see cust.html)
+
+ # this one is managed directly on the server
+ # LOCAL_CODE => "$ENV{HOME}/local",
+
+ # or you can use this, which lets you put everything in a subdirectory
+ # called "local" in your gitolite-admin repo. For a SECURITY WARNING
+ # on this, see http://gitolite.com/gitolite/non-core.html#pushcode
+ # LOCAL_CODE => "$rc{GL_ADMIN_BASE}/local",
+
+ # ------------------------------------------------------------------
+
+ # List of commands and features to enable
+
+ ENABLE => [
+
+ # COMMANDS
+
+ # These are the commands enabled by default
+ 'help',
+ 'desc',
+ 'info',
+ 'perms',
+ 'writable',
+
+ # Uncomment or add new commands here.
+ # 'create',
+ # 'fork',
+ # 'mirror',
+ # 'readme',
+ # 'sskm',
+ # 'D',
+
+ # These FEATURES are enabled by default.
+
+ # essential (unless you're using smart-http mode)
+ 'ssh-authkeys',
+
+ # creates git-config entries from gitolite.conf file entries like 'config foo.bar = baz'
+ 'git-config',
+
+ # creates git-daemon-export-ok files; if you don't use git-daemon, comment this out
+ 'daemon',
+
+ # creates projects.list file; if you don't use gitweb, comment this out
+ 'gitweb',
+
+ # These FEATURES are disabled by default; uncomment to enable. If you
+ # need to add new ones, ask on the mailing list :-)
+
+ # user-visible behaviour
+
+ # prevent wild repos auto-create on fetch/clone
+ # 'no-create-on-read',
+ # no auto-create at all (don't forget to enable the 'create' command!)
+ # 'no-auto-create',
+
+ # access a repo by another (possibly legacy) name
+ # 'Alias',
+
+ # give some users direct shell access. See documentation in
+ # sts.html for details on the following two choices.
+ # "Shell $ENV{HOME}/.gitolite.shell-users",
+ # 'Shell alice bob',
+
+ # set default roles from lines like 'option default.roles-1 = ...', etc.
+ # 'set-default-roles',
+
+ # show more detailed messages on deny
+ # 'expand-deny-messages',
+
+ # show a message of the day
+ # 'Motd',
+
+ # system admin stuff
+
+ # enable mirroring (don't forget to set the HOSTNAME too!)
+ # 'Mirroring',
+
+ # allow people to submit pub files with more than one key in them
+ # 'ssh-authkeys-split',
+
+ # selective read control hack
+ # 'partial-copy',
+
+ # manage local, gitolite-controlled, copies of read-only upstream repos
+ # 'upstream',
+
+ # updates 'description' file instead of 'gitweb.description' config item
+ # 'cgit',
+
+ # allow repo-specific hooks to be added
+ # 'repo-specific-hooks',
+
+ # performance, logging, monitoring...
+
+ # be nice
+ # 'renice 10',
+
+ # log CPU times (user, system, cumulative user, cumulative system)
+ # 'CpuTime',
+
+ # syntactic_sugar for gitolite.conf and included files
+
+ # allow backslash-escaped continuation lines in gitolite.conf
+ # 'continuation-lines',
+
+ # create implicit user groups from directory names in keydir/
+ # 'keysubdirs-as-groups',
+
+ # allow simple line-oriented macros
+ # 'macros',
+
+ # Kindergarten mode
+
+ # disallow various things that sensible people shouldn't be doing anyway
+ # 'Kindergarten',
+ ],
+
+);
+
+# ------------------------------------------------------------------------------
+# per perl rules, this should be the last line in such a file:
+1;
+
+# Local variables:
+# mode: perl
+# End:
+# vim: set syn=perl:
diff --git a/src/lib/Gitolite/Setup.pm b/src/lib/Gitolite/Setup.pm
new file mode 100644
index 0000000..8ad5d34
--- /dev/null
+++ b/src/lib/Gitolite/Setup.pm
@@ -0,0 +1,175 @@
+package Gitolite::Setup;
+
+# implements 'gitolite setup'
+# ----------------------------------------------------------------------
+
+=for args
+Usage: gitolite setup [<option>]
+
+Setup gitolite, compile conf, run the POST_COMPILE trigger (see rc file) and
+propagate hooks.
+
+ -a, --admin <name> admin name
+ -pk, --pubkey <file> pubkey file name
+ -ho, --hooks-only skip other steps and just propagate hooks
+ -m, --message set setup commit message
+
+First run: either the pubkey or the admin name is *required*, depending on
+whether you're using ssh mode or http mode.
+
+Subsequent runs:
+
+ - Without options, 'gitolite setup' is a general "fix up everything" command
+ (for example, if you brought in repos from outside, or someone messed
+ around with the hooks, or you made an rc file change that affects access
+ rules, etc.)
+
+ - '-pk' can be used to replace the admin key; useful if you lost the admin's
+ private key but do have shell access to the server.
+
+ - '-ho' is mainly for scripting use. Do not combine with other options.
+
+ - '-a' is ignored
+
+ - '-m' can be used to replace default commit message "gitolite setup $argv"
+ with a custom message (e.g. "Setting up your repository mgmt").
+
+=cut
+
+# ----------------------------------------------------------------------
+
+@EXPORT = qw(
+ setup
+);
+
+use Exporter 'import';
+
+use Gitolite::Rc;
+use Gitolite::Common;
+use Gitolite::Conf::Store;
+
+use strict;
+use warnings;
+
+# ----------------------------------------------------------------------
+
+sub setup {
+ my ( $admin, $pubkey, $h_only, $message ) = args();
+
+ unless ($h_only) {
+ setup_glrc();
+ setup_gladmin( $admin, $pubkey, $message );
+
+ _system("gitolite compile");
+ _system("gitolite trigger POST_COMPILE");
+ }
+
+ hook_repos(); # all of them, just to be sure
+}
+
+# ----------------------------------------------------------------------
+
+sub args {
+ my $admin = '';
+ my $pubkey = '';
+ my $message = '';
+ my $h_only = 0;
+ my $help = 0;
+ my $argv = join( " ", @ARGV );
+
+ require Getopt::Long;
+ Getopt::Long::GetOptions(
+ 'admin|a=s' => \$admin,
+ 'pubkey|pk=s' => \$pubkey,
+ 'message|m=s' => \$message,
+ 'hooks-only|ho' => \$h_only,
+ 'help|h' => \$help,
+ ) or usage();
+
+ usage() if $help or ( $pubkey and $admin );
+ usage() if $h_only 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";
+
+ $admin = $pubkey;
+ # next 2 lines duplicated from args() in ssh-authkeys
+ $admin =~ s(.*/)(); # foo/bar/baz.pub -> baz.pub
+ $admin =~ s/(\@[^.]+)?\.pub$//; # baz.pub, baz@home.pub -> baz
+ $pubkey =~ /\@/ and print STDERR "NOTE: the admin username is '$admin'\n";
+
+ }
+
+ return ( $admin || '', $pubkey || '', $h_only || 0, $message || "gitolite setup $argv");
+}
+
+sub setup_glrc {
+ _print( glrc('default-filename'), glrc('default-text') ) if not glrc('filename');
+}
+
+sub setup_gladmin {
+ my ( $admin, $pubkey, $message ) = @_;
+ _die "'-pk' or '-a' required; see 'gitolite setup -h' for more"
+ if not $admin and not -f "$rc{GL_ADMIN_BASE}/conf/gitolite.conf";
+
+ # 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 = '';
+ $pubkey_content = slurp($pubkey) if $pubkey;
+
+ # set up the admin files in admin-base
+
+ _mkdir( $rc{GL_ADMIN_BASE} );
+ _chdir( $rc{GL_ADMIN_BASE} );
+
+ _mkdir("conf");
+ _mkdir("logs");
+ my $conf;
+ {
+ local $/ = undef;
+ $conf = <DATA>;
+ }
+ $conf =~ s/%ADMIN/$admin/g;
+
+ _print( "conf/gitolite.conf", $conf ) if not -f "conf/gitolite.conf";
+
+ if ($pubkey) {
+ _mkdir("keydir");
+ _print( "keydir/$admin.pub", $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") if not -d "gitolite-admin.git";
+
+ # 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 '$message'")
+ 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
diff --git a/src/lib/Gitolite/Test.pm b/src/lib/Gitolite/Test.pm
new file mode 100644
index 0000000..904abbf
--- /dev/null
+++ b/src/lib/Gitolite/Test.pm
@@ -0,0 +1,122 @@
+package Gitolite::Test;
+
+# functions for the test code to use
+# ----------------------------------------------------------------------
+
+#<<<
+@EXPORT = qw(
+ try
+ put
+ text
+ lines
+ dump
+ confreset
+ confadd
+ cmp
+ md5sum
+);
+#>>>
+use Exporter 'import';
+use File::Path qw(mkpath);
+use Carp qw(carp cluck croak confess);
+use Digest::MD5 qw(md5_hex);
+
+use Gitolite::Common;
+
+BEGIN {
+ require Gitolite::Test::Tsh;
+ *{'try'} = \&Tsh::try;
+ *{'put'} = \&Tsh::put;
+ *{'text'} = \&Tsh::text;
+ *{'lines'} = \&Tsh::lines;
+ *{'cmp'} = \&Tsh::cmp;
+}
+
+use strict;
+use warnings;
+
+# ----------------------------------------------------------------------
+
+# make sure the user is ready for it
+if ( not $ENV{GITOLITE_TEST} or $ENV{GITOLITE_TEST} ne 'y' ) {
+ print "Bail out! See t/README for information on how to run the tests.\n";
+ exit 255;
+}
+
+# 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/
+
+ DEF CS_1 = pwd; //tmp/tsh_tempdir.*gitolite-admin/; git remote -v; ok; /file:///gitolite-admin/
+ DEF CHECK_SETUP = CS_1; git log; ok; /fa7564c1b903ea3dce49314753f25b34b9e0cea0/
+
+ DEF CLONE = glt clone %1 file:///%2
+ DEF PUSH = glt push %1 origin
+
+ # clean install
+ mkdir -p $ENV{HOME}/bin
+ ln -sf $ENV{PWD}/t/glt ~/bin
+ ./install -ln
+ cd; rm -vrf .gito* repositories
+ git config --file $ENV{HOME}/.gitconfig.local user.name \"gitolite tester\"
+ git config --file $ENV{HOME}/.gitconfig.local user.email \"tester\@example.com\"
+ git config --global include.path \"~/.gitconfig.local\"
+
+ # setup
+ gitolite setup -a admin
+
+ # clone admin repo
+ cd tsh_tempdir
+ glt clone admin --progress file:///gitolite-admin
+ cd gitolite-admin
+" or die "could not setup the test environment; errors:\n\n" . text() . "\n\n";
+
+sub dump {
+ use Data::Dumper;
+ for my $i (@_) {
+ print STDERR "DBG: " . Dumper($i);
+ }
+}
+
+sub _confargs {
+ return @_ if ( $_[1] );
+ return 'gitolite.conf', $_[0];
+}
+
+sub confreset {
+ chdir("../gitolite-admin") or die "in `pwd`, could not cd ../g-a";
+ system( "rm", "-rf", "conf" );
+ mkdir("conf");
+ system("mv ~/repositories/gitolite-admin.git ~/repositories/.ga");
+ system("mv ~/repositories/testing.git ~/repositories/.te");
+ system("find ~/repositories -name '*.git' |xargs rm -rf");
+ system("mv ~/repositories/.ga ~/repositories/gitolite-admin.git");
+ system("mv ~/repositories/.te ~/repositories/testing.git ");
+ put "|cut -c9- > conf/gitolite.conf", '
+ repo gitolite-admin
+ RW+ = admin
+ repo testing
+ RW+ = @all
+';
+}
+
+sub confadd {
+ chdir("../gitolite-admin") or die "in `pwd`, could not cd ../g-a";
+ my ( $file, $string ) = _confargs(@_);
+ put "|cat >> conf/$file", $string;
+}
+
+sub md5sum {
+ my $out = '';
+ for my $file (@_) {
+ $out .= md5_hex( slurp($file) ) . " $file\n";
+ }
+ return $out;
+}
+
+1;
diff --git a/src/lib/Gitolite/Test/Tsh.pm b/src/lib/Gitolite/Test/Tsh.pm
new file mode 100644
index 0000000..6861960
--- /dev/null
+++ b/src/lib/Gitolite/Test/Tsh.pm
@@ -0,0 +1,645 @@
+#!/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 cmp 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 and text
+
+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 {
+ $line = $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};
+ local $_ = shift;
+ say "1..$_";
+}
+
+sub rc_lines {
+ my @lines = @_;
+
+ while (@lines) {
+ local $_ = shift @lines;
+ chomp; $_ = trim_ws($_);
+
+ no warnings;
+ $line++;
+ use warnings;
+
+ # 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; /bin/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 cmp {
+ # compare input string with second input string or text()
+ my $in = shift;
+ my $text = ( @_ ? +shift : text() );
+
+ if ( $text eq $in ) {
+ ok();
+ } else {
+ fail( 'cmp failed', '' );
+ dbg( 4, "\n\ntext = <<<$text>>>, in = <<<$in>>>\n\n" );
+ }
+}
+
+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 {
+ local $_ = shift;
+ s/^\s+//; s/\s+$//;
+ return $_;
+}
+
+sub is_comment_or_empty {
+ local $_ = shift;
+ chomp; $_ = trim_ws($_);
+ if (/^##\s(.*)/) {
+ $testname = $1;
+ say "# $1";
+ }
+ return ( /^#/ or /^$/ );
+}
+
+sub cmds {
+ local $_ = 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 ? gmtime( $tick + 19800 ) : gmtime() );
+ _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;
diff --git a/src/lib/Gitolite/Triggers.pm b/src/lib/Gitolite/Triggers.pm
new file mode 100644
index 0000000..16e8aa6
--- /dev/null
+++ b/src/lib/Gitolite/Triggers.pm
@@ -0,0 +1,33 @@
+package Gitolite::Triggers;
+
+# load and run triggered modules
+# ----------------------------------------------------------------------
+
+#<<<
+@EXPORT = qw(
+);
+#>>>
+use Exporter 'import';
+
+use Gitolite::Rc;
+use Gitolite::Common;
+
+use strict;
+use warnings;
+
+# ----------------------------------------------------------------------
+
+sub run {
+ my ( $module, $sub, @args ) = @_;
+ $module = "Gitolite::Triggers::$module" if $module !~ /^Gitolite::/;
+
+ eval "require $module";
+ _die "$@" if $@;
+ my $subref;
+ eval "\$subref = \\\&$module" . "::" . "$sub";
+ _die "module '$module' does not exist or does not have sub '$sub'" unless ref($subref) eq 'CODE';
+
+ $subref->(@args);
+}
+
+1;
diff --git a/src/lib/Gitolite/Triggers/Alias.pm b/src/lib/Gitolite/Triggers/Alias.pm
new file mode 100644
index 0000000..adaceb5
--- /dev/null
+++ b/src/lib/Gitolite/Triggers/Alias.pm
@@ -0,0 +1,128 @@
+package Gitolite::Triggers::Alias;
+
+use Gitolite::Rc;
+use Gitolite::Common;
+use Gitolite::Conf::Load;
+
+use strict;
+use warnings;
+
+# aliasing a repo to another
+# ----------------------------------------------------------------------
+
+=for usage
+
+Why:
+
+ We had an existing repo "foo" that lots of people use. We wanted to
+ rename it to "foo/code", so that related repos "foo/upstream" and
+ "foo/docs" (both containing stuff we did not want to put in "foo") could
+ also be made and then the whole thing would be structured nicely.
+
+ At the same time we did not want to *force* all the users to change the
+ name. At least git operations should still work with the old name,
+ although it is OK for "info" and other "commands" to display/require the
+ proper name (i.e., the new name).
+
+How:
+
+ * uncomment the line "Alias" in the "user-visible behaviour" section in the
+ rc file
+
+ * add a new variable REPO_ALIASES to the rc file, with entries like:
+
+ REPO_ALIASES =>
+ {
+ # if you need a more aggressive warning message than the default
+ WARNING => "Please change your URLs to use '%new'; '%old' will not work after XXXX-XX-XX",
+
+ # prefix mapping section
+ PREFIX_MAPS => {
+ # note: NO leading slash in keys or values below
+ 'var/lib/git/' => '',
+ 'var/opt/git/' => 'opt/',
+ },
+
+ # individual repo mapping section
+ 'foo' => 'foo/code',
+
+ # force users to change their URLs
+ 'bar' => '301/bar/code',
+ # a target repo starting with "301/" won't actually work;
+ # it will just produce an error message pointing the user
+ # to the new name. This allows admins to force users to
+ # fix their URLs.
+ },
+
+ If a prefix map is supplied, each key is checked (in *undefined* order),
+ and the *first* key which matches the prefix of the repo will be applied.
+ If more than one key matches (for example if you specify '/abc/def' as one
+ key, and '/abc' as another), it is undefined which will get picked up.
+
+ The result of this, (or the original repo name if no map was found), will
+ then be subject to the individual repo mappings. Since these are full
+ repo names, there is no possibility of multiple matches.
+
+Notes:
+
+ * only git operations (clone/fetch/push) are alias aware. Nothing else in
+ gitolite, such as all the gitolite commands etc., are alias-aware and will
+ always use/require the proper repo name.
+
+ * http mode has not been tested and will not be. If someone has the time to
+ test it and make it work please let me know.
+
+ * funnily enough, this even works with mirroring! That is, a master can
+ push a repo "foo" to a copy per its configuration, while the copy thinks
+ it is getting repo "bar" from the master per its configuration.
+
+ Just make sure to put the Alias::input line *before* the Mirroring::input
+ line in the rc file on the copy.
+
+ However, it will probably not work with redirected pushes unless you setup
+ the opposite alias ("bar" -> "foo") on master.
+=cut
+
+sub input {
+ my $git_commands = "git-upload-pack|git-receive-pack|git-upload-archive";
+ my $user = $ARGV[0] || '@all'; # user name is undocumented for now
+
+ if ( $ENV{SSH_ORIGINAL_COMMAND} =~ /(?:$git_commands) '\/?(\S+)'$/ ) {
+ my $repo = $1;
+ ( my $norm = $repo ) =~ s/\.git$//; # normalised repo name
+
+ my $target = $norm;
+
+ # prefix maps first
+ my $pm = $rc{REPO_ALIASES}{PREFIX_MAPS} || {};
+ while (my($k, $v) = each %$pm) {
+ last if $target =~ s/^$k/$v/;
+ # no /i, /g, etc. by design
+ }
+
+ # individual repo map next
+ $target = $rc{REPO_ALIASES}{$target} || $target;
+
+ # undocumented; don't use without discussing on mailing list
+ $target = $target->{$user} if ref($target) eq 'HASH';
+
+ # if the repo name finally maps to empty, we bail, with no changes
+ return unless $target;
+
+ # we're done. Did we actually change anything?
+ return if $norm eq $target;
+
+ # if the new name starts with "301/", inform and abort
+ _die "please use '$target' instead of '$norm'" if $target =~ s(^301/)();
+ # otherwise print a warning and continue with the new name
+ my $wm = $rc{REPO_ALIASES}{WARNING} || "'%old' is an alias for '%new'";
+ $wm =~ s/%new/$target/g;
+ $wm =~ s/%old/$norm/g;
+ _warn $wm;
+
+ $ENV{SSH_ORIGINAL_COMMAND} =~ s/'\/?$repo'/'$target'/;
+ }
+
+}
+
+1;
diff --git a/src/lib/Gitolite/Triggers/AutoCreate.pm b/src/lib/Gitolite/Triggers/AutoCreate.pm
new file mode 100644
index 0000000..e1d977a
--- /dev/null
+++ b/src/lib/Gitolite/Triggers/AutoCreate.pm
@@ -0,0 +1,24 @@
+package Gitolite::Triggers::AutoCreate;
+
+use strict;
+use warnings;
+
+# perl trigger set for stuff to do with auto-creating repos
+# ----------------------------------------------------------------------
+
+# to deny auto-create on read access, uncomment 'no-create-on-read' in the
+# ENABLE list in the rc file
+sub deny_R {
+ die "autocreate denied\n" if $_[3] and $_[3] eq 'R';
+ return;
+}
+
+# to deny auto-create on read *and* write, uncomment 'no-auto-create' in the
+# ENABLE list in the rc file. This means you can only create wild repos using
+# the 'create' command, (which needs to be enabled in the ENABLE list).
+sub deny_RW {
+ die "autocreate denied\n" if $_[3] and ( $_[3] eq 'R' or $_[3] eq 'W' );
+ return;
+}
+
+1;
diff --git a/src/lib/Gitolite/Triggers/CpuTime.pm b/src/lib/Gitolite/Triggers/CpuTime.pm
new file mode 100644
index 0000000..74b4217
--- /dev/null
+++ b/src/lib/Gitolite/Triggers/CpuTime.pm
@@ -0,0 +1,52 @@
+package Gitolite::Triggers::CpuTime;
+
+use Time::HiRes;
+
+use Gitolite::Rc;
+use Gitolite::Common;
+
+use strict;
+use warnings;
+
+# cpu and elapsed times for gitolite+git operations
+# ----------------------------------------------------------------------
+# uncomment the appropriate lines in the rc file to enable this
+
+# Ideally, you will (a) write your own code with a different filename so later
+# gitolite upgrades won't overwrite your copy, (b) add appropriate variables
+# to the rc file, and (c) change your rc file to call your program instead.
+
+# ----------------------------------------------------------------------
+my $start_time;
+
+sub input {
+ _warn "something wrong with the invocation of CpuTime::input" if $ENV{GL_TID} ne $$;
+ $start_time = [ Time::HiRes::gettimeofday() ];
+}
+
+sub post_git {
+ _warn "something wrong with the invocation of CpuTime::post_git" if $ENV{GL_TID} ne $$;
+
+ my ( $trigger, $repo, $user, $aa, $ref, $verb ) = @_;
+ my ( $utime, $stime, $cutime, $cstime ) = times();
+ my $elapsed = Time::HiRes::tv_interval($start_time);
+
+ gl_log( 'times', $utime, $stime, $cutime, $cstime, $elapsed );
+
+ # now do whatever you want with the data; the following is just an example.
+
+ if ( my $limit = $rc{CPU_TIME_WARN_LIMIT} ) {
+ my $total = $utime + $cutime + $stime + $cstime;
+ # some code to send an email or whatever...
+ say2 "limit = $limit, actual = $total" if $total > $limit;
+ }
+
+ if ( $rc{DISPLAY_CPU_TIME} ) {
+ say2 "perf stats for $verb on repo '$repo':";
+ say2 " user CPU time: " . ( $utime + $cutime );
+ say2 " sys CPU time: " . ( $stime + $cstime );
+ say2 " elapsed time: " . $elapsed;
+ }
+}
+
+1;
diff --git a/src/lib/Gitolite/Triggers/Kindergarten.pm b/src/lib/Gitolite/Triggers/Kindergarten.pm
new file mode 100755
index 0000000..6274c3d
--- /dev/null
+++ b/src/lib/Gitolite/Triggers/Kindergarten.pm
@@ -0,0 +1,99 @@
+package Gitolite::Triggers::Kindergarten;
+
+# http://www.great-quotes.com/quote/424177
+# "Doctor, it hurts when I do this."
+# "Then don't do that!"
+
+# Prevent various things that sensible people shouldn't be doing anyway. List
+# of things it prevents is at the end of the program.
+
+# If you were forced to enable this module because someone is *constantly*
+# doing things that need to be caught, consider getting rid of that person.
+# Because, really, who knows what *else* he/she is doing that can't be caught
+# with some clever bit of code?
+
+use Gitolite::Rc;
+use Gitolite::Common;
+
+use strict;
+use warnings;
+
+my %active;
+sub active {
+ # in rc, you either see just 'Kindergarten' to activate all features, or
+ # 'Kindergarten U0 CREATOR' (i.e., a space sep list of features after the
+ # word Kindergarten) to activate only those named features.
+
+ # no features specifically activated; implies all of them are active
+ return 1 if not %active;
+ # else check if this specific feature is active
+ return 1 if $active{ +shift };
+
+ return 0;
+}
+
+my ( $verb, $repo, $cmd, $args );
+sub input {
+ # get the features to be activated, if supplied
+ while ( $_[0] ne 'INPUT' ) {
+ $active{ +shift } = 1;
+ }
+
+ # generally fill up variables you might use later
+ my $git_commands = "git-upload-pack|git-receive-pack|git-upload-archive";
+ if ( $ENV{SSH_ORIGINAL_COMMAND} =~ /($git_commands) '\/?(\S+)'$/ ) {
+ $verb = $1;
+ $repo = $2;
+ } elsif ( $ENV{SSH_ORIGINAL_COMMAND} =~ /^(\S+) (.*)$/ ) {
+ $cmd = $1;
+ $args = $2;
+ }
+
+ prevent_CREATOR($repo) if active('CREATOR') and $verb;
+ prevent_0(@ARGV) if active('U0') and @ARGV;
+}
+
+sub prevent_CREATOR {
+ my $repo = shift;
+ _die "'CREATOR' not allowed as part of reponame" if $repo =~ /\bCREATOR\b/;
+}
+
+sub prevent_0 {
+ my $user = shift;
+ _die "'0' is not a valid username" if $user eq '0';
+}
+
+1;
+
+__END__
+
+CREATOR
+
+ prevent literal 'CREATOR' from being part of a repo name
+
+ a quirk deep inside gitolite would let this config
+
+ repo foo/CREATOR/..*
+ C = ...
+
+ allow the creation of repos like "foo/CREATOR/bar", i.e., the word CREATOR is
+ literally used.
+
+ I consider this a totally pathological situation to check for. The worst that
+ can happen is someone ends up cluttering the server with useless repos.
+
+ One solution could be to prevent this only for wild repos, but I can't be
+ bothered to fine tune this, so this module prevents even normal repos from
+ having the literal CREATOR in them.
+
+ See https://groups.google.com/forum/#!topic/gitolite/cS34Vxix0Us for more.
+
+U0
+
+ prevent a user from being called literal '0'
+
+ Ideally we should prevent keydir/0.pub (or variants) from being created,
+ but for "Then don't do that" purposes it's enough to prevent the user from
+ logging in.
+
+ See https://groups.google.com/forum/#!topic/gitolite/F1IBenuSTZo for more.
diff --git a/src/lib/Gitolite/Triggers/Mirroring.pm b/src/lib/Gitolite/Triggers/Mirroring.pm
new file mode 100644
index 0000000..07b7f96
--- /dev/null
+++ b/src/lib/Gitolite/Triggers/Mirroring.pm
@@ -0,0 +1,256 @@
+package Gitolite::Triggers::Mirroring;
+
+use Gitolite::Rc;
+use Gitolite::Common;
+use Gitolite::Conf::Load;
+
+use strict;
+use warnings;
+
+my $hn = $rc{HOSTNAME};
+
+my ( $mode, $master, %copies, %trusted_copies );
+
+# ----------------------------------------------------------------------
+
+sub input {
+ unless ( $ARGV[0] =~ /^server-(\S+)$/ ) {
+ _die "'$ARGV[0]' is not a valid server name" if $ENV{SSH_ORIGINAL_COMMAND} =~ /^USER=(\S+) SOC=(git-receive-pack '(\S+)')$/;
+ return;
+ }
+
+ # note: we treat %rc as our own internal "poor man's %ENV"
+ $rc{FROM_SERVER} = $1;
+ trace( 3, "from_server: $1" );
+ my $sender = $rc{FROM_SERVER} || '';
+
+ # custom peer-to-peer commands. At present the only one is 'perms -c',
+ # sent from a mirror command
+ if ( $ENV{SSH_ORIGINAL_COMMAND} =~ /^CREATOR=(\S+) perms -c '(\S+)'$/ ) {
+ $ENV{GL_USER} = $1;
+
+ my $repo = $2;
+ details($repo);
+ _die "$hn: '$repo' is local" if $mode eq 'local';
+ _die "$hn: '$repo' is native" if $mode eq 'master';
+ _die "$hn: '$sender' is not the master for '$repo'" if $master ne $sender;
+
+ $ENV{GL_BYPASS_CREATOR_CHECK} = option($repo, "bypass-creator-check");
+ # this expects valid perms content on STDIN
+ _system("gitolite perms -c $repo");
+ delete $ENV{GL_BYPASS_CREATOR_CHECK};
+
+ # we're done. Yes, really...
+ exit 0;
+ }
+
+ if ( $ENV{SSH_ORIGINAL_COMMAND} =~ /^USER=(\S+) SOC=(git-receive-pack '(\S+)')$/ ) {
+ # my ($user, $newsoc, $repo) = ($1, $2, $3);
+ $ENV{SSH_ORIGINAL_COMMAND} = $2;
+ @ARGV = ($1);
+ $rc{REDIRECTED_PUSH} = 1;
+ trace( 3, "redirected_push for user $1" );
+ } else {
+ # master -> copy push, no access checks needed
+ $ENV{GL_BYPASS_ACCESS_CHECKS} = 1;
+ }
+}
+
+# ----------------------------------------------------------------------
+
+sub pre_git {
+ return unless $hn;
+ # nothing, and I mean NOTHING, happens if HOSTNAME is not set
+ trace( 3, "pre_git() on $hn" );
+
+ my ( $repo, $user, $aa ) = @_[ 1, 2, 3 ];
+
+ my $sender = $rc{FROM_SERVER} || '';
+ $user = '' if $sender and not exists $rc{REDIRECTED_PUSH};
+
+ # ------------------------------------------------------------------
+ # now you know the repo, get its mirroring details
+ details($repo);
+
+ # print mirror status if at least one copy status file is present
+ print_status( $repo ) if not $rc{HUSH_MIRROR_STATUS} and $mode ne 'local' and glob("$rc{GL_REPO_BASE}/$repo.git/gl-copy-*.status");
+
+ # we don't deal with any reads. Note that for pre-git this check must
+ # happen *after* getting details, to give mode() a chance to die on "known
+ # unknown" repos (repos that are in the config, but mirror settings
+ # exclude this host from both the master and copy lists)
+ return if $aa eq 'R';
+
+ trace( 1, "mirror", "pre_git", $repo, "user=$user", "sender=$sender", "mode=$mode", ( $rc{REDIRECTED_PUSH} ? ("redirected") : () ) );
+
+ # ------------------------------------------------------------------
+ # case 1: we're master or copy, normal user pushing to us
+ if ( $user and not $rc{REDIRECTED_PUSH} ) {
+ trace( 3, "case 1, user push" );
+ return if $mode eq 'local' or $mode eq 'master';
+ if ( $trusted_copies{$hn} ) {
+ trace( 1, "redirect to $master" );
+ exec( "ssh", $master, "USER=$user", "SOC=$ENV{SSH_ORIGINAL_COMMAND}" );
+ } else {
+ _die "$hn: pushing '$repo' to copy '$hn' not allowed";
+ }
+ }
+
+ # ------------------------------------------------------------------
+ # case 2: we're copy, master pushing to us
+ if ( $sender and not $rc{REDIRECTED_PUSH} ) {
+ trace( 3, "case 2, master push" );
+ _die "$hn: '$repo' is local" if $mode eq 'local';
+ _die "$hn: '$repo' is native" if $mode eq 'master';
+ _die "$hn: '$sender' is not the master for '$repo'" if $master ne $sender;
+ return;
+ }
+
+ # ------------------------------------------------------------------
+ # case 3: we're master, copy sending a redirected push to us
+ if ( $sender and $rc{REDIRECTED_PUSH} ) {
+ trace( 3, "case 2, copy redirect" );
+ _die "$hn: '$repo' is local" if $mode eq 'local';
+ _die "$hn: '$repo' is not native" if $mode eq 'copy';
+ _die "$hn: '$sender' is not a valid copy for '$repo'" if not $copies{$sender};
+ _die "$hn: redirection not allowed from '$sender'" if not $trusted_copies{$sender};
+ return;
+ }
+
+ _die "$hn: should not reach this line";
+
+}
+
+# ----------------------------------------------------------------------
+
+sub post_git {
+ return unless $hn;
+ # nothing, and I mean NOTHING, happens if HOSTNAME is not set
+ trace( 1, "post_git() on $hn" );
+
+ my ( $repo, $user, $aa ) = @_[ 1, 2, 3 ];
+ # we don't deal with any reads
+ return if $aa eq 'R';
+
+ my $sender = $rc{FROM_SERVER} || '';
+ $user = '' if $sender;
+
+ # ------------------------------------------------------------------
+ # now you know the repo, get its mirroring details
+ details($repo);
+
+ trace( 1, "mirror", "post_git", $repo, "user=$user", "sender=$sender", "mode=$mode", ( $rc{REDIRECTED_PUSH} ? ("redirected") : () ) );
+
+ # ------------------------------------------------------------------
+ # case 1: we're master or copy, normal user pushing to us
+ if ( $user and not $rc{REDIRECTED_PUSH} ) {
+ trace( 3, "case 1, user push" );
+ return if $mode eq 'local';
+ # copy was eliminated earlier anyway, so that leaves 'master'
+
+ # find all copies and push to each of them
+ push_to_copies($repo);
+
+ return;
+ }
+
+ # ------------------------------------------------------------------
+ # case 2: we're copy, master pushing to us
+ if ( $sender and not $rc{REDIRECTED_PUSH} ) {
+ trace( 3, "case 2, master push" );
+ # nothing to do
+ return;
+ }
+
+ # ------------------------------------------------------------------
+ # case 3: we're master, copy sending a redirected push to us
+ if ( $sender and $rc{REDIRECTED_PUSH} ) {
+ trace( 3, "case 2, copy redirect" );
+
+ # find all copies and push to each of them
+ push_to_copies($repo);
+
+ return;
+ }
+}
+
+{
+ my $lastrepo = '';
+
+ sub details {
+ my $repo = shift;
+ return if $lastrepo eq $repo;
+
+ $master = master($repo);
+ %copies = copies($repo);
+ $mode = mode($repo);
+ %trusted_copies = trusted_copies($repo);
+ trace( 3, $master, $mode, join( ",", sort keys %copies ), join( ",", sort keys %trusted_copies ) );
+ }
+
+ sub master {
+ return option( +shift, 'mirror.master' );
+ }
+
+ sub copies {
+ my $repo = shift;
+
+ my $ref = git_config( $repo, "^gitolite-options\\.mirror\\.copies.*" );
+ my %out = map { $_ => 'async' } map { split } values %$ref;
+
+ $ref = git_config( $repo, "^gitolite-options\\.mirror\\.copies\\.sync.*" );
+ map { $out{$_} = 'sync' } map { split } values %$ref;
+
+ $ref = git_config( $repo, "^gitolite-options\\.mirror\\.copies\\.nosync.*" );
+ map { $out{$_} = 'nosync' } map { split } values %$ref;
+
+ return %out;
+ }
+
+ sub trusted_copies {
+ my $ref = git_config( +shift, "^gitolite-options\\.mirror\\.redirectOK.*" );
+ # the list of trusted copies (where we accept redirected pushes from)
+ # is either explicitly given...
+ my @out = map { split } values %$ref;
+ my %out = map { $_ => 1 } @out;
+ # ...or it's all the copies mentioned if the list is just a "all"
+ %out = %copies if ( @out == 1 and $out[0] eq 'all' );
+ return %out;
+ }
+
+ sub mode {
+ my $repo = shift;
+ return 'local' if not $hn;
+ return 'master' if $master eq $hn;
+ return 'copy' if $copies{$hn};
+ return 'local' if not $master and not %copies;
+ _die "$hn: '$repo' is mirrored but not here";
+ }
+}
+
+sub push_to_copies {
+ my $repo = shift;
+
+ my $u = $ENV{GL_USER};
+ delete $ENV{GL_USER}; # why? see src/commands/mirror
+
+ my $lb = "$ENV{GL_REPO_BASE}/$repo.git/.gl-mirror-lock";
+ for my $s ( sort keys %copies ) {
+ trace( 1, "push_to_copies skipping self" ), next if $s eq $hn;
+ system("gitolite 1plus1 $lb.$s gitolite mirror push $s $repo </dev/null >/dev/null 2>&1 &") if $copies{$s} eq 'async';
+ system("gitolite 1plus1 $lb.$s gitolite mirror push $s $repo </dev/null >/dev/null 2>&1") if $copies{$s} eq 'sync';
+ _warn "manual mirror push pending for '$s'" if $copies{$s} eq 'nosync';
+ }
+
+ $ENV{GL_USER} = $u;
+}
+
+sub print_status {
+ my $repo = shift;
+ my $u = $ENV{GL_USER};
+ delete $ENV{GL_USER};
+ system("gitolite mirror status all $repo >&2");
+ $ENV{GL_USER} = $u;
+}
+
+1;
diff --git a/src/lib/Gitolite/Triggers/Motd.pm b/src/lib/Gitolite/Triggers/Motd.pm
new file mode 100644
index 0000000..6de80a2
--- /dev/null
+++ b/src/lib/Gitolite/Triggers/Motd.pm
@@ -0,0 +1,29 @@
+package Gitolite::Triggers::Motd;
+
+use Gitolite::Rc;
+use Gitolite::Common;
+
+use strict;
+use warnings;
+
+# print a message of the day to STDERR
+# ----------------------------------------------------------------------
+
+my $file = "gl-motd";
+
+sub input {
+ # at present, we print it for every single interaction with gitolite. We
+ # may want to change that later; if we do, get code from Kindergarten.pm
+ # to get the gitcmd+repo or cmd+args so you can filter on them
+
+ my $f = "$rc{GL_ADMIN_BASE}/$file";
+ print STDERR slurp($f) if -f $f;
+}
+
+sub pre_git {
+ my $repo = $_[1];
+ my $f = "$rc{GL_REPO_BASE}/$repo.git/$file";
+ print STDERR slurp($f) if -f $f;
+}
+
+1;
diff --git a/src/lib/Gitolite/Triggers/RefexExpr.pm b/src/lib/Gitolite/Triggers/RefexExpr.pm
new file mode 100644
index 0000000..e913665
--- /dev/null
+++ b/src/lib/Gitolite/Triggers/RefexExpr.pm
@@ -0,0 +1,80 @@
+package Gitolite::Triggers::RefexExpr;
+use strict;
+use warnings;
+
+# track refexes passed and evaluate expressions on them
+# ----------------------------------------------------------------------
+# see src/VREF/refex-expr for instructions and WARNINGS!
+
+use Gitolite::Easy;
+
+my %passed;
+my %rules;
+my $init_done = 0;
+
+sub access_2 {
+ # get out quick for repos that don't have any rules
+ return if $init_done and not %rules;
+
+ # but we don't really know that the first time, heh!
+ if ( not $init_done ) {
+ my $repo = $_[1];
+ init($repo);
+ return unless %rules;
+ }
+
+ my $refex = $_[5];
+ return if $refex =~ /DENIED/;
+
+ $passed{$refex}++;
+
+ # evaluate the rules each time; it's not very expensive
+ for my $k ( sort keys %rules ) {
+ $ENV{ "GL_REFEX_EXPR_" . $k } = eval_rule( $rules{$k} );
+ }
+}
+
+sub eval_rule {
+ my $rule = shift;
+
+ my $e;
+ $e = join " ", map { convert($_) } split ' ', $rule;
+
+ my $ret = eval $e;
+ _die "eval '$e' -> '$@'" if $@;
+ Gitolite::Common::trace( 1, "RefexExpr", "'$rule' -> '$e' -> '$ret'" );
+
+ return "'$rule' -> '$e'" if $ret;
+}
+
+my %constant;
+%constant = map { $_ => $_ } qw(1 not and or xor + - ==);
+$constant{'-lt'} = '<';
+$constant{'-gt'} = '>';
+$constant{'-eq'} = '==';
+$constant{'-le'} = '<=';
+$constant{'-ge'} = '>=';
+$constant{'-ne'} = '!=';
+
+sub convert {
+ my $i = shift;
+ return $i if $i =~ /^-?\d+$/;
+ return $constant{$i} || $passed{$i} || $passed{"refs/heads/$i"} || 0;
+}
+
+# called only once
+sub init {
+ $init_done = 1;
+ my $repo = shift;
+
+ # find all the rule expressions
+ my %t = config( $repo, "^gitolite-options\\.refex-expr\\." );
+ my ( $k, $v );
+ # get rid of the cruft and store just the rule name as the key
+ while ( ( $k, $v ) = each %t ) {
+ $k =~ s/^gitolite-options\.refex-expr\.//;
+ $rules{$k} = $v;
+ }
+}
+
+1;
diff --git a/src/lib/Gitolite/Triggers/RepoUmask.pm b/src/lib/Gitolite/Triggers/RepoUmask.pm
new file mode 100644
index 0000000..276cd01
--- /dev/null
+++ b/src/lib/Gitolite/Triggers/RepoUmask.pm
@@ -0,0 +1,62 @@
+package Gitolite::Triggers::RepoUmask;
+
+use Gitolite::Rc;
+use Gitolite::Common;
+use Gitolite::Conf::Load;
+
+use strict;
+use warnings;
+
+# setting a repo specific umask
+# ----------------------------------------------------------------------
+# this is for people who are too paranoid to trust e.g., gitweb's repo
+# exclusion logic, but not paranoid enough to put it on a different server
+
+=for usage
+
+ * In the rc file, add the line
+ 'RepoUmask',
+ somewhere in the ENABLE list
+
+ * For each repo that is to get a different umask than the default, add a
+ line like this:
+
+ option umask = 0027
+
+ * Anytime you add or change the value, if there are existing repos that
+ would be affected, you will need to do a manual "chmod" adjustment,
+ because umask only affects newly created files.
+
+=cut
+
+# sadly option/config values are not available at pre_create time for normal
+# repos. So we have to do a one-time fixup in a post_create trigger.
+sub post_create {
+ my $repo = $_[1];
+
+ my $umask = option( $repo, 'umask' );
+ _chdir( $rc{GL_REPO_BASE} ); # because using option() moves us to ADMIN_BASE!
+
+ return unless $umask;
+
+ # unlike the one in the rc file, this is a string
+ $umask = oct($umask);
+ my $mode = "0" . sprintf( "%o", $umask ^ 0777 );
+
+ system("chmod -R $mode $repo.git >&2");
+ system("find $repo.git -type f -exec chmod a-x '{}' \\;");
+}
+
+sub pre_git {
+ my $repo = $_[1];
+
+ my $umask = option( $repo, 'umask' );
+ _chdir( $rc{GL_REPO_BASE} ); # because using option() moves us to ADMIN_BASE!
+
+ return unless $umask;
+
+ # unlike the one in the rc file, this is a string
+ umask oct($umask);
+}
+
+1;
diff --git a/src/lib/Gitolite/Triggers/Shell.pm b/src/lib/Gitolite/Triggers/Shell.pm
new file mode 100644
index 0000000..a2c5c0d
--- /dev/null
+++ b/src/lib/Gitolite/Triggers/Shell.pm
@@ -0,0 +1,66 @@
+package Gitolite::Triggers::Shell;
+
+# usage notes: uncomment 'Shell' in the ENABLE list in the rc file.
+
+# documentation is in the ssh troubleshooting and tips document, under the
+# section "giving shell access to gitolite users"
+
+use Gitolite::Rc;
+use Gitolite::Common;
+
+# fedora likes to do things that are a little off the beaten track, compared
+# to typical gitolite usage:
+# - every user has their own login
+# - the forced command may not get the username as an argument. If it does
+# not, the gitolite user name is $USER (the unix user name)
+# - and finally, if the first argument to the forced command is '-s', and
+# $SSH_ORIGINAL_COMMAND is empty or runs a non-git/gitolite command, then
+# the user gets a shell
+
+sub input {
+ my $shell_allowed = 0;
+ if ( @ARGV and $ARGV[0] eq '-s' ) {
+ shift @ARGV;
+ $shell_allowed++;
+ }
+
+ @ARGV = ( $ENV{USER} ) unless @ARGV;
+
+ return unless $shell_allowed;
+
+ # now determine if this was intended as a shell command or git/gitolite
+ # command
+
+ my $soc = $ENV{SSH_ORIGINAL_COMMAND};
+
+ # no command, just 'ssh alice@host'; doesn't return ('exec's out)
+ shell_out() if $shell_allowed and not $soc;
+
+ return if git_gitolite_command($soc);
+
+ gl_log( 'shell', $ENV{SHELL}, "-c", $soc );
+ exec $ENV{SHELL}, "-c", $soc;
+}
+
+sub shell_out {
+ my $shell = $ENV{SHELL};
+ $shell =~ s/.*\//-/; # change "/bin/bash" to "-bash"
+ gl_log( 'shell', $shell );
+ exec { $ENV{SHELL} } $shell;
+}
+
+# some duplication with gitolite-shell, factor it out later, if it works fine
+# for fedora and they like it.
+sub git_gitolite_command {
+ my $soc = shift;
+
+ my $git_commands = "git-upload-pack|git-receive-pack|git-upload-archive";
+ return 1 if $soc =~ /^($git_commands) /;
+
+ my @words = split ' ', $soc;
+ return 1 if $rc{COMMANDS}{ $words[0] };
+
+ return 0;
+}
+
+1;
diff --git a/src/lib/Gitolite/Triggers/TProxy.pm b/src/lib/Gitolite/Triggers/TProxy.pm
new file mode 100644
index 0000000..9c42918
--- /dev/null
+++ b/src/lib/Gitolite/Triggers/TProxy.pm
@@ -0,0 +1,98 @@
+package Gitolite::Triggers::TProxy;
+
+# ----------------------------------------------------------------------
+# transparent proxy for git repos, hosted on a gitolite server
+
+# ----------------------------------------------------------------------
+# WHAT
+
+# 1. user runs a git command (clone, fetch, push) against a gitolite
+# server.
+# 2. if that server has the repo, it will serve it up. Else it will
+# *transparently* forward the git operation to a designated upstream
+# server. The user does not have to do anything, and in fact may not
+# even know this has happened.
+
+# can be combined with, but does not *require*, gitolite mirroring.
+
+# ----------------------------------------------------------------------
+# SECURITY
+#
+# 1. Most of the issues that apply to "redirected push" in mirroring.html
+# also apply here. In particular, you had best make sure the two
+# servers use the same authentication data (i.e., "alice" here should be
+# "alice" there!)
+#
+# 2. Also, do not add keys for servers you don't trust!
+
+# ----------------------------------------------------------------------
+# HOW
+
+# on transparent proxy server (the one that is doing the redirect):
+# 1. add
+# INPUT => ['TProxy::input'],
+# just before the ENABLE list in the rc file
+# 2. add an RC variable to tell gitolite where to go; this is also just
+# before the ENABLE list:
+# TPROXY_FORWARDS_TO => 'git@upstream',
+
+# on upstream server (the one redirected TO):
+# 1. add
+# INPUT => ['TProxy::input'],
+# just before the ENABLE list in the rc file
+# 2. add the pubkey of the proxy server (the one that will be redirecting
+# to us) to this server's gitolite-admin "keydir" as
+# "server-<something>.pub", and push the change.
+
+# to use in combination with gitolite mirroring
+# 1. just follow the same instructions as above. Server names and
+# corresponding pub keys would already be set ok so step 2 in the
+# upstream server setup (above) will not be needed.
+# 2. needless to say, **don't** declare the repos you want to be
+# transparently proxied in the gitolite.conf for the copy.
+
+use Gitolite::Rc;
+use Gitolite::Common;
+use Gitolite::Conf::Load;
+
+use strict;
+use warnings;
+
+my $soc = $ENV{SSH_ORIGINAL_COMMAND};
+
+# ----------------------------------------------------------------------
+
+sub input {
+ # are we the upstream, getting something from a tproxy server?
+ my $git_commands = "git-upload-pack|git-receive-pack|git-upload-archive";
+ if ( $ARGV[0] =~ /^server-/ and $soc =~ /^TPROXY_FOR=(\S+) SOC=(($git_commands) '\S+')$/ ) {
+ @ARGV = ($1);
+ # you better make sure you read the security warnings up there!
+
+ $ENV{SSH_ORIGINAL_COMMAND} = $2;
+ delete $ENV{GL_BYPASS_ACCESS_CHECKS};
+ # just in case we somehow end up running before Mirroring::input!
+
+ return;
+ }
+
+ # well we're not upstream; are we a tproxy?
+ return unless $rc{TPROXY_FORWARDS_TO};
+
+ # is it a normal git command?
+ return unless $ENV{SSH_ORIGINAL_COMMAND} =~ m(^($git_commands) '/?(.*?)(?:\.git(\d)?)?'$);
+
+ # ...get the repo name from $ENV{SSH_ORIGINAL_COMMAND}
+ my ( $verb, $repo, $trace_level ) = ( $1, $2, $3 );
+ $ENV{D} = $trace_level if $trace_level;
+ _die "invalid repo name: '$repo'" if $repo !~ $REPONAME_PATT;
+
+ # nothing to do if the repo exists locally
+ return if -d "$ENV{GL_REPO_BASE}/$repo.git";
+
+ my $user = shift @ARGV;
+ # redirect to upstream
+ exec( "ssh", $rc{TPROXY_FORWARDS_TO}, "TPROXY_FOR=$user", "SOC=$ENV{SSH_ORIGINAL_COMMAND}" );
+}
+
+1;
diff --git a/src/lib/Gitolite/Triggers/Writable.pm b/src/lib/Gitolite/Triggers/Writable.pm
new file mode 100644
index 0000000..ed86e12
--- /dev/null
+++ b/src/lib/Gitolite/Triggers/Writable.pm
@@ -0,0 +1,17 @@
+package Gitolite::Triggers::Writable;
+
+use Gitolite::Rc;
+use Gitolite::Common;
+
+sub access_1 {
+ my ( $repo, $aa, $result ) = @_[ 1, 3, 5 ];
+ return if $aa eq 'R' or $result =~ /DENIED/;
+
+ for my $f ( "$ENV{HOME}/.gitolite.down", "$rc{GL_REPO_BASE}/$repo.git/.gitolite.down" ) {
+ next unless -f $f;
+ _die slurp($f) if -s $f;
+ _die "sorry, writes are currently disabled (no more info available)\n";
+ }
+}
+
+1;