diff options
author | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-07 14:17:27 +0000 |
---|---|---|
committer | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-07 14:17:27 +0000 |
commit | aae1a14ea756102251351d96e2567b4986d30e2b (patch) | |
tree | a1af617672e26aee4c1031a3aa83e8ff08f6a0a5 /src/lib/Gitolite/Common.pm | |
parent | Initial commit. (diff) | |
download | gitolite3-aae1a14ea756102251351d96e2567b4986d30e2b.tar.xz gitolite3-aae1a14ea756102251351d96e2567b4986d30e2b.zip |
Adding upstream version 3.6.12.upstream/3.6.12upstream
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to '')
-rw-r--r-- | src/lib/Gitolite/Common.pm | 422 |
1 files changed, 422 insertions, 0 deletions
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; |