2048484578
this error normally happens due to some permission issue on the log file, but we weren't printing the actual cause, so it was confusing
325 lines
8.2 KiB
Perl
325 lines
8.2 KiB
Perl
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
|
|
);
|
|
#>>>
|
|
use Exporter 'import';
|
|
use File::Path qw(mkpath);
|
|
use Carp qw(carp cluck croak confess);
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
# ----------------------------------------------------------------------
|
|
|
|
sub print2 {
|
|
local $/ = "\n";
|
|
print STDERR @_;
|
|
}
|
|
|
|
sub say {
|
|
local $/ = "\n";
|
|
print @_, "\n";
|
|
}
|
|
|
|
sub say2 {
|
|
local $/ = "\n";
|
|
print STDERR @_, "\n";
|
|
}
|
|
|
|
sub trace {
|
|
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 $args = ''; $args = join( ", ", @_ ) if @_;
|
|
my $sub = ( caller 1 )[3] || ''; $sub =~ s/.*://;
|
|
if ( not $sub ) {
|
|
$sub = (caller)[1];
|
|
$sub =~ s(.*/(.*))(($1));
|
|
}
|
|
$sub .= ' ' x ( 32 - length($sub) );
|
|
say2 "TRACE $level $sub", ( @_ ? shift : () );
|
|
say2( "TRACE $level " . ( " " x 32 ), $_ ) for @_;
|
|
}
|
|
|
|
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(@_);
|
|
}
|
|
|
|
{
|
|
use Time::HiRes;
|
|
my %start_times;
|
|
|
|
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 {
|
|
_warn(shift) if @_;
|
|
my $script = (caller)[1];
|
|
my $function = ( ( ( caller(1) )[3] ) || ( ( caller(0) )[3] ) );
|
|
$function =~ s/.*:://;
|
|
my $code = slurp($script);
|
|
$code =~ /^=for $function\b(.*?)^=cut/sm;
|
|
say2( $1 ? $1 : "...no usage message 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
|
|
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;
|
|
|
|
# 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 @_ );
|
|
|
|
for my $repo (`find . -name "*.git" -prune`) {
|
|
chomp($repo);
|
|
$repo =~ s(\./(.*)\.git$)($1);
|
|
push @phy_repos, $repo;
|
|
}
|
|
trace( 2, scalar(@phy_repos) . " physical repos found" );
|
|
return sort_u( \@phy_repos );
|
|
}
|
|
}
|
|
|
|
# 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;
|
|
}
|
|
|
|
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} ||= $$;
|
|
|
|
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;
|
|
}
|
|
|
|
# ----------------------------------------------------------------------
|
|
|
|
# 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;
|