src/lib/Gitolite/Common.pm

   1 package Gitolite::Common;
   2
   3 # common (non-gitolite-specific) functions
   4 # ----------------------------------------------------------------------
   5
   6 #<<<
   7 @EXPORT = qw(
   8   print2  dbg     _mkdir  _open   ln_sf     tsh_rc      sort_u
   9   say     _warn   _chdir  _print            tsh_text    list_phy_repos
  10   say2    _die    _system slurp             tsh_lines
  11           trace           cleanup_conf_line tsh_try
  12           usage                             tsh_run
  13           gen_lfn
  14           gl_log
  15
  16           dd
  17           t_start
  18           t_lap
  19
  20           ssh_fingerprint_file
  21           ssh_fingerprint_line
  22
  23           update_hook_present
  24 );
  25 #>>>
  26 use Exporter 'import';
  27 use File::Path qw(mkpath);
  28 use File::Temp qw(tempfile);
  29 use Carp qw(carp cluck croak confess);
  30
  31 use strict;
  32 use warnings;
  33
  34 # ----------------------------------------------------------------------
  35
  36 sub print2 {
  37     local $/ = "\n";
  38     print STDERR @_;
  39 }
  40
  41 sub say {
  42     local $/ = "\n";
  43     print @_, "\n";
  44 }
  45
  46 sub say2 {
  47     local $/ = "\n";
  48     print STDERR @_, "\n";
  49 }
  50
  51 sub trace {
  52     gl_log( "\t" . join( ",", @_[ 1 .. $#_ ] ) ) if $_[0] <= 1 and defined $Gitolite::Rc::rc{LOG_EXTRA};
  53
  54     return unless defined( $ENV{D} );
  55
  56     my $level = shift; return if $ENV{D} < $level;
  57     my $sub = ( caller 1 )[3] || ''; $sub =~ s/.*://;
  58     if ( not $sub ) {
  59         $sub = (caller)[1];
  60         $sub =~ s(.*/(.*))(($1));
  61     }
  62     $sub .= ' ' x ( 31 - length($sub) );
  63     say2 "$level\t$sub\t", join( "\t", @_ );
  64 }
  65
  66 sub dbg {
  67     use Data::Dumper;
  68     return unless defined( $ENV{D} );
  69     for my $i (@_) {
  70         print STDERR "DBG: " . Dumper($i);
  71     }
  72 }
  73
  74 sub dd {
  75     local $ENV{D} = 1;
  76     dbg(@_);
  77 }
  78
  79 {
  80     my %start_times;
  81
  82     eval "require Time::HiRes";
  83     # we just ignore any errors from this; nothing needs to be done as long as
  84     # no code *calls* either of the next two functions.
  85
  86     sub t_start {
  87         my $name = shift || 'default';
  88         $start_times{$name} = [ Time::HiRes::gettimeofday() ];
  89     }
  90
  91     sub t_lap {
  92         my $name = shift || 'default';
  93         return Time::HiRes::tv_interval( $start_times{$name} );
  94     }
  95 }
  96
  97 sub _warn {
  98     gl_log( 'warn', @_ );
  99     if ( $ENV{D} and $ENV{D} >= 3 ) {
 100         cluck "WARNING: ", @_, "\n";
 101     } elsif ( defined( $ENV{D} ) ) {
 102         carp "WARNING: ", @_, "\n";
 103     } else {
 104         warn "WARNING: ", @_, "\n";
 105     }
 106 }
 107 $SIG{__WARN__} = \&_warn;
 108
 109 sub _die {
 110     gl_log( 'die', @_ );
 111     if ( $ENV{D} and $ENV{D} >= 3 ) {
 112         confess "FATAL: " . join( ",", @_ ) . "\n" if defined( $ENV{D} );
 113     } elsif ( defined( $ENV{D} ) ) {
 114         croak "FATAL: " . join( ",", @_ ) . "\n";
 115     } else {
 116         die "FATAL: " . join( ",", @_ ) . "\n";
 117     }
 118 }
 119 $SIG{__DIE__} = \&_die;
 120
 121 sub usage {
 122     my $script = (caller)[1];
 123     my $function = shift if @_ and $_[0] =~ /^[\w-]+$/;
 124     $function ||= ( ( ( caller(1) )[3] ) || ( ( caller(0) )[3] ) );
 125     $function =~ s/.*:://;
 126     my $code = slurp($script);
 127     $code =~ /^=for $function\b(.*?)^=cut/sm;
 128     say( $1 ? $1 : "...no usage message for '$function' in $script" );
 129     exit 1;
 130 }
 131
 132 sub _mkdir {
 133     # It's not an error if the directory exists, but it is an error if it
 134     # doesn't exist and we can't create it. This includes not guaranteeing
 135     # dead symlinks or if mkpath traversal is blocked by a file.
 136     my $dir  = shift;
 137     my $perm = shift;    # optional
 138     return if -d $dir;
 139     mkpath($dir);
 140     chmod $perm, $dir if $perm;
 141     return 1;
 142 }
 143
 144 sub _chdir {
 145     chdir( $_[0] || $ENV{HOME} ) or _die "chdir $_[0] failed: $!\n";
 146 }
 147
 148 sub _system {
 149     # run system(), catch errors.  Be verbose only if $ENV{D} exists.  If not,
 150     # exit with <rc of system()> if it applies, else just "exit 1".
 151     trace( 1, 'system', @_ );
 152     if ( system(@_) != 0 ) {
 153         trace( 1, "system() failed", @_, "-> $?" );
 154         if ( $? == -1 ) {
 155             die "failed to execute: $!\n" if $ENV{D};
 156         } elsif ( $? & 127 ) {
 157             die "child died with signal " . ( $? & 127 ) . "\n" if $ENV{D};
 158         } else {
 159             die "child exited with value " . ( $? >> 8 ) . "\n" if $ENV{D};
 160             exit( $? >> 8 );
 161         }
 162         exit 1;
 163     }
 164 }
 165
 166 sub _open {
 167     open( my $fh, $_[0], $_[1] ) or _die "open $_[1] failed: $!\n";
 168     return $fh;
 169 }
 170
 171 sub _print {
 172     my ( $file, @text ) = @_;
 173     my $fh = _open( ">", "$file.$$" );
 174     print $fh @text;
 175     close($fh) or _die "close $file failed: $! at ", (caller)[1], " line ", (caller)[2], "\n";
 176     my $oldmode = ( ( stat $file )[2] );
 177     rename "$file.$$", $file;
 178     chmod $oldmode, $file if $oldmode;
 179 }
 180
 181 sub slurp {
 182     return unless defined wantarray;
 183     local $/ = undef unless wantarray;
 184     my $fh = _open( "<", $_[0] );
 185     return <$fh>;
 186 }
 187
 188 sub dos2unix {
 189     # WARNING: when calling this, make sure you supply a list context
 190     s/\r\n/\n/g for @_;
 191     return @_;
 192 }
 193
 194 sub ln_sf {
 195     trace( 3, @_ );
 196     my ( $srcdir, $glob, $dstdir ) = @_;
 197     for my $hook ( glob("$srcdir/$glob") ) {
 198         $hook =~ s/$srcdir\///;
 199         unlink "$dstdir/$hook";
 200         symlink "$srcdir/$hook", "$dstdir/$hook" or croak "could not symlink $srcdir/$hook to $dstdir\n";
 201     }
 202 }
 203
 204 sub sort_u {
 205     my %uniq;
 206     my $listref = shift;
 207     return [] unless @{$listref};
 208     undef @uniq{ @{$listref} };    # expect a listref
 209     my @sort_u = sort keys %uniq;
 210     return \@sort_u;
 211 }
 212
 213 sub cleanup_conf_line {
 214     my $line = shift;
 215     return $line if $line =~ /^# \S+ \d+$/;
 216
 217     # kill comments, but take care of "#" inside *simple* strings
 218     $line =~ s/^((".*?"|[^#"])*)#.*/$1/;
 219     # normalise whitespace; keeps later regexes very simple
 220     $line =~ s/=/ = /;
 221     $line =~ s/\s+/ /g;
 222     $line =~ s/^ //;
 223     $line =~ s/ $//;
 224     return $line;
 225 }
 226
 227 {
 228     my @phy_repos = ();
 229
 230     sub list_phy_repos {
 231         # use cached value only if it exists *and* no arg was received (i.e.,
 232         # receiving *any* arg invalidates cache)
 233         return \@phy_repos if ( @phy_repos and not @_ );
 234
 235         my $cmd = 'find . ' . ($Gitolite::Rc::rc{REPO_SYMLINKS} || '') . ' -name "*.git" -prune';
 236         for my $repo (`$cmd`) {
 237             chomp($repo);
 238             $repo =~ s/\.git$//;
 239             $repo =~ s(^\./)();
 240             next if $repo =~ m(/$);
 241                 # tolerate non-bare repos within ~/repositories but silently ignore them
 242             push @phy_repos, $repo;
 243         }
 244         trace( 3, scalar(@phy_repos) . " physical repos found" );
 245         return sort_u( \@phy_repos );
 246     }
 247 }
 248
 249 sub update_hook_present {
 250     my $repo = shift;
 251
 252     return 1 unless -d "$ENV{GL_REPO_BASE}/$repo.git";  # non-existent repo is fine
 253
 254     my $x = readlink("$ENV{GL_REPO_BASE}/$repo.git/hooks/update");
 255     return 1 if $x and $x eq "$ENV{GL_ADMIN_BASE}/hooks/common/update";
 256
 257     return 0;
 258 }
 259
 260 # generate a timestamp
 261 sub gen_ts {
 262     my ( $s, $min, $h, $d, $m, $y ) = (localtime)[ 0 .. 5 ];
 263     $y += 1900; $m++;    # usual adjustments
 264     for ( $s, $min, $h, $d, $m ) {
 265         $_ = "0$_" if $_ < 10;
 266     }
 267     my $ts = "$y-$m-$d.$h:$min:$s";
 268
 269     return $ts;
 270 }
 271
 272 # generate a log file name
 273 sub gen_lfn {
 274     my ( $s, $min, $h, $d, $m, $y ) = (localtime)[ 0 .. 5 ];
 275     $y += 1900; $m++;    # usual adjustments
 276     for ( $s, $min, $h, $d, $m ) {
 277         $_ = "0$_" if $_ < 10;
 278     }
 279
 280     my ($template) = shift;
 281     # substitute template parameters and set the logfile name
 282     $template =~ s/%y/$y/g;
 283     $template =~ s/%m/$m/g;
 284     $template =~ s/%d/$d/g;
 285
 286     return $template;
 287 }
 288
 289 my $log_dest;
 290 my $syslog_opened = 0;
 291 END { closelog() if $syslog_opened; }
 292 sub gl_log {
 293     # the log filename and the timestamp come from the environment.  If we get
 294     # called even before they are set, we have no choice but to dump to STDERR
 295     # (and probably call "logger").
 296
 297     # tab sep if there's more than one field
 298     my $msg = join( "\t", @_ );
 299     $msg =~ s/[\n\r]+/<<newline>>/g;
 300
 301     my $ts = gen_ts();
 302     my $tid = $ENV{GL_TID} ||= $$;
 303
 304     $log_dest = $Gitolite::Rc::rc{LOG_DEST} || '' if not defined $log_dest;
 305
 306     # log (update records only) to "gl-log" in the bare repo dir; this is to
 307     # make 'who-pushed' more efficient.  Since this is only for the update
 308     # records, it is not a replacement for the other two types of logging.
 309     if ($log_dest =~ /repo-log/ and $_[0] eq 'update') {
 310         # if the log line is 'update', we're already in the bare repo dir
 311         open my $lfh, ">>", "gl-log" or _die "open gl-log failed: $!";
 312         print $lfh "$ts\t$tid\t$msg\n";
 313         close $lfh;
 314     }
 315
 316     # syslog
 317     if ($log_dest =~ /syslog/) {            # log_dest *includes* syslog
 318         if ($syslog_opened == 0) {
 319             require Sys::Syslog;
 320             Sys::Syslog->import(qw(:standard));
 321
 322             openlog("gitolite" . ( $ENV{GL_TID} ? "[$ENV{GL_TID}]" : "" ), "pid", $Gitolite::Rc::rc{LOG_FACILITY} || 'local0');
 323             $syslog_opened = 1;
 324         }
 325
 326         # gl_log is called either directly, or, if the rc variable LOG_EXTRA
 327         # is set, from trace(1, ...).  The latter use is considered additional
 328         # info for troubleshooting.  Trace prefixes a tab to the arguments
 329         # before calling gl_log, to visually set off such lines in the log
 330         # file.  Although syslog eats up that leading tab, we use it to decide
 331         # the priority/level of the syslog message.
 332         syslog( ( $msg =~ /^\t/ ? 'debug' : 'info' ), "%s", $msg);
 333
 334         return if $log_dest !~ /normal/;
 335     }
 336
 337     my $fh;
 338     logger_plus_stderr( "errors found before logging could be setup", "$msg" ) if not $ENV{GL_LOGFILE};
 339     open my $lfh, ">>", $ENV{GL_LOGFILE}
 340       or logger_plus_stderr( "errors found but logfile could not be created", "$ENV{GL_LOGFILE}: $!", "$msg" );
 341     print $lfh "$ts\t$tid\t$msg\n";
 342     close $lfh;
 343 }
 344
 345 sub logger_plus_stderr {
 346     open my $fh, "|-", "logger" or confess "it's really not my day is it...?\n";
 347     for (@_) {
 348         print STDERR "FATAL: $_\n";
 349         print $fh "FATAL: $_\n";
 350     }
 351     exit 1;
 352 }
 353
 354 # ----------------------------------------------------------------------
 355 # Get the SSH fingerprint of a file
 356 # If the fingerprint cannot be parsed, it will be undef
 357 # In a scalar context, returns the fingerprint
 358 # In a list context, returns (fingerprint, output) where output
 359 # is the raw output of the ssh-keygen command
 360 sub ssh_fingerprint_file {
 361     my $in = shift;
 362     -f $in or die "file not found: $in\n";
 363     my $fh;
 364     open( $fh, "ssh-keygen -l -f $in 2>&1 |" ) or die "could not fork: $!\n";
 365     my $output = <$fh>;
 366     chomp $output;
 367     # dbg("fp = $fp");
 368     close $fh;
 369     # Return a valid fingerprint or undef
 370     my $fp = undef;
 371     if($output =~ /((?:MD5:)?(?:[0-9a-f]{2}:){15}[0-9a-f]{2})/i or
 372        $output =~ m{((?:RIPEMD|SHA)\d+:[A-Za-z0-9+/=]+)}i) {
 373         $fp = $1;
 374     }
 375     return wantarray ? ($fp, $output) : $fp;
 376 }
 377
 378 # Get the SSH fingerprint of a line of text
 379 # If the fingerprint cannot be parsed, it will be undef
 380 # In a scalar context, returns the fingerprint
 381 # In a list context, returns (fingerprint, output) where output
 382 # is the raw output of the ssh-keygen command
 383 sub ssh_fingerprint_line {
 384     my ( $fh, $fn ) = tempfile();
 385     print $fh shift() . "\n";
 386     close $fh;
 387     my ($fp,$output) = ssh_fingerprint_file($fn);
 388     unlink $fn;
 389     return wantarray ? ($fp,$output) : $fp;
 390 }
 391
 392 # ----------------------------------------------------------------------
 393
 394 # bare-minimum subset of 'Tsh' (see github.com/sitaramc/tsh)
 395 {
 396     my ( $rc, $text );
 397     sub tsh_rc   { return $rc   || 0; }
 398     sub tsh_text { return $text || ''; }
 399     sub tsh_lines { return split /\n/, $text; }
 400
 401     sub tsh_try {
 402         my $cmd = shift; die "try: expects only one argument" if @_;
 403         $text = `( $cmd ) 2>&1; printf RC=\$?`;
 404         if ( $text =~ s/RC=(\d+)$// ) {
 405             $rc = $1;
 406             trace( 3, $text );
 407             return ( not $rc );
 408         }
 409         die "couldnt find RC= in result; this should not happen:\n$text\n\n...\n";
 410     }
 411
 412     sub tsh_run {
 413         open( my $fh, "-|", @_ ) or die "popen failed: $!";
 414         local $/ = undef; $text = <$fh>;
 415         close $fh; warn "pclose failed: $!" if $!;
 416         $rc = ( $? >> 8 );
 417         trace( 3, $text );
 418         return $text;
 419     }
 420 }
 421
 422 1;