Girocco/Util.pm

   1 package Girocco::Util;
   2
   3 use 5.008;
   4 use strict;
   5 use warnings;
   6
   7 use Girocco::Config;
   8 use Time::Local;
   9 use Encode;
  10
  11 BEGIN {
  12         use base qw(Exporter);
  13         our @EXPORT = qw(get_git scrypt jailed_file sendmail_pipe mailer_pipe
  14                          lock_file unlock_file valid_tag rand_adjust
  15                          filedb_atomic_append filedb_atomic_edit filedb_grep
  16                          filedb_atomic_grep valid_email valid_email_multi
  17                          valid_repo_url valid_web_url url_base url_path url_server
  18                          projects_html_list parse_rfc2822_date parse_any_date
  19                          extract_url_hostname is_dns_hostname is_our_hostname
  20                          get_cmd online_cpus sys_pagesize sys_memsize
  21                          calc_windowmemory to_utf8 capture_command human_size
  22                          calc_bigfilethreshold has_reserved_suffix human_duration
  23                          noFatalsToBrowser calc_redeltathreshold
  24                          clean_email_multi read_HEAD_symref read_config_file
  25                          read_config_file_hash is_git_dir git_bool util_path
  26                          is_shellish read_HEAD_ref git_add_config);
  27 }
  28
  29 my $encoder;
  30 BEGIN {
  31         $encoder = Encode::find_encoding('Windows-1252') ||
  32                    Encode::find_encoding('ISO-8859-1') or
  33                    die "failed to load ISO-8859-1 encoder\n";
  34 }
  35
  36 sub to_utf8($;$) {
  37         my ($str, $encode) = @_;
  38         return undef unless defined $str;
  39         my $ans;
  40         if (Encode::is_utf8($str) || utf8::decode($str)) {
  41                 $ans = $str;
  42         } else {
  43                 $ans = $encoder->decode($str, Encode::FB_DEFAULT);
  44         }
  45         utf8::encode($ans) if $encode;
  46         return $ans;
  47 }
  48
  49 BEGIN {require "Girocco/extra/capture_command.pl"}
  50
  51 # Return the entire output sent to stdout from running a command
  52 # Any output the command sends to stderr is discarded
  53 # Returns undef if there was an error running the command (see $!)
  54 sub get_cmd {
  55         my ($status, $result) = capture_command(1, undef, @_);
  56         return defined($status) && $status == 0 ? $result : undef;
  57 }
  58
  59 # Same as get_cmd except configured git binary is automatically provided
  60 # as the first argument to get_cmd
  61 sub get_git {
  62         return get_cmd($Girocco::Config::git_bin, @_);
  63 }
  64
  65 sub scrypt {
  66         my ($pwd) = @_;
  67         crypt($pwd||'', join ('', ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]));
  68 }
  69
  70 sub jailed_file {
  71         my ($filename) = @_;
  72         $filename =~ s,^/,,;
  73         $Girocco::Config::chroot."/$filename";
  74 }
  75
  76 sub lock_file {
  77         my ($path) = @_;
  78
  79         $path .= '.lock';
  80
  81         use Errno qw(EEXIST);
  82         use Fcntl qw(O_WRONLY O_CREAT O_EXCL);
  83         use IO::Handle;
  84         my $handle = new IO::Handle;
  85
  86         unless (sysopen($handle, $path, O_WRONLY|O_CREAT|O_EXCL)) {
  87                 my $cnt = 0;
  88                 while (not sysopen($handle, $path, O_WRONLY|O_CREAT|O_EXCL)) {
  89                         ($! == EEXIST) or die "$path open failed: $!";
  90                         ($cnt++ < 16) or die "$path open failed: cannot open lockfile";
  91                         sleep(1);
  92                 }
  93         }
  94         # XXX: filedb-specific
  95         chmod 0664, $path or die "$path g+w failed: $!";
  96
  97         $handle;
  98 }
  99
 100 sub _is_passwd_file {
 101         return defined($_[0]) && $_[0] eq jailed_file('/etc/passwd');
 102 }
 103
 104 sub _run_update_pwd_db {
 105         my ($path, $updatearg) = @_;
 106         my @cmd = ($Girocco::Config::basedir.'/bin/update-pwd-db', "$path");
 107         push(@cmd, $updatearg) if $updatearg;
 108         system(@cmd) == 0 or die "update-pwd-db failed: $?";
 109 }
 110
 111 sub unlock_file {
 112         my ($path, $noreplace, $updatearg) = @_;
 113
 114         if (!$noreplace) {
 115                 _run_update_pwd_db("$path.lock", $updatearg)
 116                         if $Girocco::Config::update_pwd_db && _is_passwd_file($path);
 117                 rename "$path.lock", $path or die "$path unlock failed: $!";
 118         } else {
 119                 unlink "$path.lock" or die "$path unlock failed: $!";
 120         }
 121 }
 122
 123 sub filedb_atomic_append {
 124         my ($file, $line, $updatearg) = @_;
 125         my $id = 65536;
 126
 127         open my $src, '<', $file or die "$file open for reading failed: $!";
 128         my $dst = lock_file($file);
 129
 130         while (<$src>) {
 131                 my $aid = (split /:/)[2];
 132                 $id = $aid + 1 if ($aid >= $id);
 133
 134                 print $dst $_ or die "$file(l) write failed: $!";
 135         }
 136
 137         $line =~ s/\\i/$id/g;
 138         print $dst "$line\n" or die "$file(l) write failed: $!";
 139
 140         close $dst or die "$file(l) close failed: $!";
 141         close $src;
 142
 143         unlock_file($file, 0, $updatearg);
 144
 145         $id;
 146 }
 147
 148 sub filedb_atomic_edit {
 149         my ($file, $fn, $updatearg) = @_;
 150
 151         open my $src, '<', $file or die "$file open for reading failed: $!";
 152         my $dst = lock_file($file);
 153
 154         while (<$src>) {
 155                 print $dst $fn->($_) or die "$file(l) write failed: $!";
 156         }
 157
 158         close $dst or die "$file(l) close failed: $!";
 159         close $src;
 160
 161         unlock_file($file, 0, $updatearg);
 162 }
 163
 164 sub filedb_atomic_grep {
 165         my ($file, $fn) = @_;
 166         my @results = ();
 167
 168         open my $src, '<', $file or die "$file open for reading failed: $!";
 169         my $dst = lock_file($file);
 170
 171         while (<$src>) {
 172                 my $result = $fn->($_);
 173                 push(@results, $result) if $result;
 174         }
 175
 176         close $dst or die "$file(l) close failed: $!";
 177         close $src;
 178
 179         unlock_file($file, 1);
 180         return @results;
 181 }
 182
 183 sub filedb_grep {
 184         my ($file, $fn) = @_;
 185         my @results = ();
 186
 187         open my $src, '<', $file or die "$file open for reading failed: $!";
 188
 189         while (<$src>) {
 190                 my $result = $fn->($_);
 191                 push(@results, $result) if $result;
 192         }
 193
 194         close $src;
 195
 196         return @results;
 197 }
 198
 199 sub valid_email {
 200         my $email = shift;
 201         defined($email) or $email = '';
 202         return $email =~ /^[a-zA-Z0-9+._-]+@[a-zA-Z0-9.-]+$/;
 203 }
 204
 205 sub clean_email_multi {
 206         my $input = shift;
 207         defined($input) or $input = '';
 208         $input =~ s/^\s+//; $input =~ s/\s+$//;
 209         my %seen = ();
 210         my @newlist = ();
 211         foreach (split(/\s*,\s*/, $input)) {
 212                 next if $_ eq "";
 213                 $seen{lc($_)} = 1, push(@newlist, $_) unless $seen{lc($_)};
 214         }
 215         return join(",", @newlist);
 216 }
 217
 218 sub valid_email_multi {
 219         # each email address must be a valid_email but we silently
 220         # ignore extra spaces at the beginning/end and around any comma(s)
 221         foreach (split(/,/, clean_email_multi(shift))) {
 222                 return 0 unless valid_email($_);
 223         }
 224         return 1;
 225 }
 226
 227 sub valid_web_url {
 228         my $url = shift;
 229         defined($url) or $url = '';
 230         return $url =~
 231                 /^https?:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~:?&=;-]*)?(#[a-zA-Z0-9._-]+)?$/;
 232 }
 233
 234 sub valid_repo_url {
 235         my $url = shift || '';
 236         # Currently neither username nor password is allowed in the URL (except for svn)
 237         # and IPv6 literal addresses are not accepted either.
 238         $Girocco::Config::mirror_svn &&
 239                 $url =~ /^svn(\+https?)?:\/\/([^\@\/\s]+\@)?[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/os
 240                 and return 1;
 241         $Girocco::Config::mirror_darcs &&
 242                 $url =~ /^darcs(?:\+https?)?:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/os
 243                 and return 1;
 244         $Girocco::Config::mirror_bzr &&
 245                 $url =~ /^bzr:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/os
 246                 and return 1;
 247         $Girocco::Config::mirror_hg &&
 248                 $url =~ /^hg\+https?:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/os
 249                 and return 1;
 250         return $url =~  /^(https?|git):\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/;
 251 }
 252
 253 sub extract_url_hostname {
 254         my $url = shift || '';
 255         if ($url =~ m,^bzr://,) {
 256                 $url =~ s,^bzr://,,;
 257                 return 'launchpad.net' if $url =~ /^lp:/;
 258         }
 259         return undef unless $url =~ m,^[A-Za-z0-9+.-]+://[^/],;
 260         $url =~ s,^[A-Za-z0-9+.-]+://,,;
 261         $url =~ s,^([^/]+).*$,$1,;
 262         $url =~ s/:[0-9]*$//;
 263         $url =~ s/^[^\@]*[\@]//;
 264         return $url ? $url : undef;
 265 }
 266
 267 # See these RFCs:
 268 #   RFC 1034 section 3.5
 269 #   RFC 1123 section 2.1
 270 #   RFC 1738 section 3.1
 271 #   RFC 2606 sections 2 & 3
 272 #   RFC 3986 section 3.2.2
 273 sub is_dns_hostname {
 274         my $host = shift;
 275         defined($host) or $host = '';
 276         return 0 if $host eq '' || $host =~ /\s/;
 277         # first remove a trailing '.'
 278         $host =~ s/\.$//;
 279         return 0 if length($host) > 255;
 280         my $octet = '(?:\d|[1-9]\d|1\d{2}|2[0-4]\d|25[0-5])';
 281         return 0 if $host =~ /^$octet\.$octet\.$octet\.$octet$/o;
 282         my @labels = split(/[.]/, $host, -1);
 283         return 0 unless @labels && @labels >= $Girocco::Config::min_dns_labels;
 284         # now check each label
 285         foreach my $label (@labels) {
 286                 return 0 unless length($label) > 0 && length($label) <= 63;
 287                 return 0 unless $label =~ /^[A-Za-z0-9](?:[A-Za-z0-9-]*[A-Za-z0-9])?$/;
 288         }
 289         # disallow RFC 2606 names provided at least two labels are present
 290         if (@labels >= 2) {
 291                 my $tld = lc($labels[-1]);
 292                 return 0 if
 293                     $tld eq 'test' ||
 294                     $tld eq 'example' ||
 295                     $tld eq 'invalid' ||
 296                     $tld eq 'localhost';
 297                 my $sld = lc($labels[-2]);
 298                 return 0 if $sld eq 'example' &&
 299                     ($tld eq 'com' || $tld eq 'net' || $tld eq 'org');
 300         }
 301         return 1;
 302 }
 303
 304 sub is_our_hostname {
 305         my $test = shift || '';
 306         $test =~ s/\.$//;
 307         my %names = ();
 308         my @urls = (
 309                 $Girocco::Config::gitweburl,
 310                 $Girocco::Config::gitwebfiles,
 311                 $Girocco::Config::webadmurl,
 312                 $Girocco::Config::bundlesurl,
 313                 $Girocco::Config::htmlurl,
 314                 $Girocco::Config::httppullurl,
 315                 $Girocco::Config::httpbundleurl,
 316                 $Girocco::Config::httpspushurl,
 317                 $Girocco::Config::gitpullurl,
 318                 $Girocco::Config::pushurl
 319         );
 320         foreach my $url (@urls) {
 321                 if ($url) {
 322                         my $host = extract_url_hostname($url);
 323                         if (defined($host)) {
 324                                 $host =~ s/\.$//;
 325                                 $names{lc($host)} = 1;
 326                         }
 327                 }
 328         }
 329         return $names{lc($test)} ? 1 : 0;
 330 }
 331
 332 my (%_oktags, %_badtags, %_canontags, $_canontagscreated, @_whitetags);
 333 BEGIN {
 334         # These are always okay (a "whitelist") even if they would
 335         # otherwise not be allowed
 336         @_whitetags = (qw(
 337                 .net 2d 3d 6502 68000 68008 68010 68020 68030 68040 68060
 338                 8086 80286 80386 80486 80586 c cc make www x
 339         ));
 340         map({$_oktags{lc($_)}=1} @_whitetags, @Girocco::Config::allowed_tags);
 341         # entries MUST be all lowercase to be effective
 342         %_badtags = (
 343         # These are "nonsense" or pointless tags
 344         about=>1, after=>1, all=>1, also=>1, an=>1, and=>1, another=>1, any=>1,
 345         are=>1, as=>1, at=>1, be=>1, because=>1, been=>1, before=>1, being=>1,
 346         between=>1, both=>1, but=>1, by=>1, came=>1, can=>1, come=>1, could=>1,
 347         did=>1, do=>1, each=>1, for=>1, from=>1, get=>1, got=>1, had=>1, has=>1,
 348         have=>1, he=>1, her=>1, here=>1, him=>1, himself=>1, his=>1, how=>1,
 349         if=>1, in=>1, into=>1, is=>1, it=>1, like=>1, make=>1, many=>1, me=>1,
 350         might=>1, more=>1, most=>1, much=>1, must=>1, my=>1, never=>1, now=>1,
 351         of=>1, oh=>1, on=>1, only=>1, or=>1, other=>1, our=>1, out=>1, over=>1,
 352         said=>1, same=>1, see=>1, should=>1, since=>1, some=>1, still=>1,
 353         such=>1, take=>1, than=>1, that=>1, the=>1, their=>1, them=>1, then=>1,
 354         there=>1, these=>1, they=>1, this=>1, those=>1, through=>1, to=>1,
 355         too=>1, under=>1, up=>1, very=>1, was=>1, way=>1, we=>1, well=>1,
 356         were=>1, what=>1, where=>1, which=>1, while=>1, who=>1, with=>1,
 357         would=>1, yea=>1, yeah=>1, you=>1, your=>1, yup=>1
 358         );
 359         # These are "offensive" tags with at least one letter escaped to
 360         # avoid having this file trigger various safe-scan robots
 361         $_badtags{"a\x73\x73"} = 1;
 362         $_badtags{"a\x73\x73hole"} = 1;
 363         $_badtags{"b\x30\x30b"} = 1;
 364         $_badtags{"b\x30\x30bs"} = 1;
 365         $_badtags{"b\x6f\x6fb"} = 1;
 366         $_badtags{"b\x6f\x6fbs"} = 1;
 367         $_badtags{"b\x75tt"} = 1;
 368         $_badtags{"b\x75ttd\x69\x63k"} = 1;
 369         $_badtags{"c\x6f\x63k"} = 1;
 370         $_badtags{"c\x75\x6e\x74"} = 1;
 371         $_badtags{"d\x69\x63k"} = 1;
 372         $_badtags{"d\x69\x63kb\x75tt"} = 1;
 373         $_badtags{"f\x75\x63k"} = 1;
 374         $_badtags{"in\x63\x65st"} = 1;
 375         $_badtags{"ph\x75\x63k"} = 1;
 376         $_badtags{"p\x6f\x72n"} = 1;
 377         $_badtags{"p\x6f\x72no"} = 1;
 378         $_badtags{"p\x6f\x72nographic"} = 1;
 379         $_badtags{"p\x72\x30n"} = 1;
 380         $_badtags{"p\x72\x6fn"} = 1;
 381         $_badtags{"r\x61\x70e"} = 1;
 382         $_badtags{"s\x65\x78"} = 1;
 383         map({$_badtags{lc($_)}=1} @Girocco::Config::blocked_tags);
 384 }
 385
 386 # A valid tag must only have [a-zA-Z0-9:.+#_-] characters, must start with a
 387 # letter, must not be a noise word, must be more than one character long,
 388 # must not be a repeated letter and must be no more than 32 characters long.
 389 # However, anything in %_oktags is explicitly allowed even if it otherwise
 390 # would violate the rules (except that none of [,\s\\\/] are allowed in tags).
 391 # Returns the canonical name for the tag if the tag is valid otherwise undef.
 392 sub valid_tag {
 393         local $_ = $_[0];
 394         return undef unless defined($_) && $_ ne "" && !/[,\s\/\\]/;
 395         my $fold = $Girocco::Config::foldtags;
 396         if ($fold && !$_canontagscreated) {
 397                 local $_;
 398                 %_canontags = ();
 399                 $_canontags{lc($_)} = $_ foreach sort({$b cmp $a} @_whitetags, @Girocco::Config::allowed_tags);
 400                 $_canontagscreated = 1;
 401         }
 402         return $_canontags{lc($_)} if $fold && exists($_canontags{lc($_)});
 403         return ($fold ? lc($_) : $_) if $_oktags{lc($_)};
 404         return undef unless /^[a-zA-Z][a-zA-Z0-9:.+#_-]+$/;
 405         return undef if $_badtags{lc($_)};
 406         return undef if /^(.)\1+$/;
 407         return length($_) <= 32 ? ($fold ? lc($_) : $_) : undef;
 408 }
 409
 410 # If the passed in argument looks like a URL, return only the stuff up through
 411 # the host:port part otherwise return the entire argument.
 412 sub url_base {
 413         my $url = shift || '';
 414         # See RFC 3968
 415         $url = $1.$2.$3.$4 if $url =~ m,^( [A-Za-z][A-Za-z0-9+.-]*: ) # scheme
 416                 ( // )          # // separator
 417                 ((?:[^\@]+\@)?) # optional userinfo
 418                 ( [^/?#]+ )     # host and port
 419                 (?:[/?#].*)?$,x; # path and optional query string and/or anchor
 420         return $url;
 421 }
 422
 423 # If the passed in argument looks like a URL, return only the stuff following
 424 # the host:port part otherwise return the entire argument.
 425 # If the optional second argument is true, the returned value will have '/'
 426 # appended if it does not already end in '/'.
 427 sub url_path {
 428         my $url = shift || '';
 429         my $add_slash = shift || 0;
 430         # See RFC 3968
 431         $url = $1 if $url =~ m,^(?: [A-Za-z][A-Za-z0-9+.-]*: ) # scheme
 432                 (?: // )        # // separator
 433                 (?: [^\@]+\@ )? # optional userinfo
 434                 (?: [^/?#]+ )   # host and port
 435                 ((?:[/?#].*)?)$,x; # path and optional query string and/or anchor
 436         $url .= '/' if $add_slash && $url !~ m|/$|;
 437         return $url;
 438 }
 439
 440 # If both SERVER_NAME and SERVER_PORT are set pass the argument through url_path
 441 # and then prefix it with the appropriate scheme (HTTPS=?on), host and port and
 442 # return it.  If a something that doesn't look like it could be the start of a
 443 # URL path comes back from url_path or SERVER_NAME is a link-local IPv6 address
 444 # then just return the argument unchanged.
 445 sub url_server {
 446         my $url = shift || '';
 447         my $path = url_path($url);
 448         return $url unless $path eq '' || $path =~ m|^[/?#]|;
 449         return $url unless $ENV{'SERVER_NAME'} && $ENV{'SERVER_PORT'} &&
 450                 $ENV{'SERVER_PORT'} =~ /^[1-9][0-9]{0,4}$/;
 451         return $url if $ENV{'SERVER_NAME'} =~ /^[[]?fe80:/i;
 452         my $server = $ENV{'SERVER_NAME'};
 453         # Deal with Apache bug where IPv6 literal server names do not include
 454         # the required surrounding '[' and ']' characters
 455         $server = '[' . $server . ']' if $server =~ /:/ && $server !~ /^[[]/;
 456         my $ishttps = $ENV{'HTTPS'} && $ENV{'HTTPS'} =~ /^on$/i;
 457         my $portnum = 0 + $ENV{'SERVER_PORT'};
 458         my $port = '';
 459         if (($ishttps && $portnum != 443) || (!$ishttps && $portnum != 80)) {
 460                 $port = ':' . $portnum;
 461         }
 462         return 'http' . ($ishttps ? 's' : '') . '://' . $server . $port . $path;
 463 }
 464
 465 # Returns the number rounded to the nearest tenths.  The ".d" part will be
 466 # excluded if it's ".0" unless the optional second argument is true
 467 sub _tenths {
 468         my $v = shift;
 469         my $use0 = shift;
 470         $v *= 10;
 471         $v += 0.5;
 472         $v = int($v);
 473         return '' . int($v/10) unless $v % 10 || $use0;
 474         return '' . int($v/10) . '.' . ($v%10);
 475 }
 476
 477 # Returns a human-readable size string (e.g. '1.5 MiB') for the value
 478 # (in bytes) passed in.  Returns '0' for undefined or 0 or not all digits.
 479 # Otherwise returns '1 KiB' for < 1024, or else a number rounded to the
 480 # nearest tenths of a KiB, MiB or GiB.
 481 sub human_size {
 482         my $v = shift || 0;
 483         return "0" unless $v && $v =~ /^\d+$/;
 484         return "1 KiB" unless $v > 1024;
 485         $v /= 1024;
 486         return _tenths($v) . " KiB" if $v < 1024;
 487         $v /= 1024;
 488         return _tenths($v) . " MiB" if $v < 1024;
 489         $v /= 1024;
 490         return _tenths($v) . " GiB";
 491 }
 492
 493 # Returns a human duration string (e.g. 1h10m5s for the value (in secs)
 494 # passed in.  Returns the value unchanged if it's not defined or <= 0.
 495 sub human_duration {
 496         my $secs = shift;
 497         return $secs unless defined($secs) && $secs >= 0;
 498         $secs = int($secs);
 499         my $ans = ($secs % 60) . 's';
 500         return $ans if $secs < 60;
 501         $secs = int($secs / 60);
 502         $ans = ($secs % 60) . 'm' . $ans;
 503         return $ans if $secs < 60;
 504         $secs = int($secs / 60);
 505         $ans = ($secs % 24) . 'h' . $ans;
 506         return $ans if $secs < 24;
 507         $secs = int($secs / 24);
 508         return $secs . 'd' . $ans;
 509 }
 510
 511 sub _escapeHTML {
 512         my $str = shift;
 513         $str =~ s/\&/\&amp;/gs;
 514         $str =~ s/\</\&lt;/gs;
 515         $str =~ s/\>/\&gt;/gs;
 516         $str =~ s/\"/\&quot;/gs; #"
 517         return $str;
 518 }
 519
 520 # create relative time string from passed in age in seconds
 521 sub _rel_age {
 522         my $age = shift;
 523         my $age_str;
 524
 525         if ($age > 60*60*24*365*2) {
 526                 $age_str = (int $age/60/60/24/365);
 527                 $age_str .= " years ago";
 528         } elsif ($age > 60*60*24*(365/12)*2) {
 529                 $age_str = int $age/60/60/24/(365/12);
 530                 $age_str .= " months ago";
 531         } elsif ($age > 60*60*24*7*2) {
 532                 $age_str = int $age/60/60/24/7;
 533                 $age_str .= " weeks ago";
 534         } elsif ($age > 60*60*24*2) {
 535                 $age_str = int $age/60/60/24;
 536                 $age_str .= " days ago";
 537         } elsif ($age > 60*60*2) {
 538                 $age_str = int $age/60/60;
 539                 $age_str .= " hours ago";
 540         } elsif ($age > 60*2) {
 541                 $age_str = int $age/60;
 542                 $age_str .= " mins ago";
 543         } elsif ($age > 2) {
 544                 $age_str = int $age;
 545                 $age_str .= " secs ago";
 546         } elsif ($age >= 0) {
 547                 $age_str = "right now";
 548         } else {
 549                 $age_str = "future time";
 550         }
 551         return $age_str;
 552 }
 553
 554 # create relative time string from passed in idle in seconds
 555 sub _rel_idle {
 556         my $idle_str = _rel_age(shift);
 557         $idle_str =~ s/ ago//;
 558         $idle_str = "not at all" if $idle_str eq "right now";
 559         return $idle_str;
 560 }
 561
 562 sub _strftime {
 563         use POSIX qw(strftime);
 564         my ($fmt, $secs, $zonesecs) = @_;
 565         my ($S,$M,$H,$d,$m,$y) = gmtime($secs + $zonesecs);
 566         $zonesecs = int($zonesecs / 60);
 567         $fmt =~ s/%z/\$z/g;
 568         my $ans = strftime($fmt, $S, $M, $H, $d, $m, $y, -1, -1, -1);
 569         my $z;
 570         if ($zonesecs < 0) {
 571                 $z = "-";
 572                 $zonesecs = -$zonesecs;
 573         } else {
 574                 $z = "+";
 575         }
 576         $z .= sprintf("%02d%02d", int($zonesecs/60), $zonesecs % 60);
 577         $ans =~ s/\$z/$z/g;
 578         return $ans;
 579 }
 580
 581 # Take a list of project names and produce a nicely formated table that
 582 # includes owner links and descriptions.  If the list is empty returns ''.
 583 # The first argument may be a hash ref that contains options.  The following
 584 # options are available:
 585 #   target  -- sets the target value of the owner link
 586 #   emptyok -- if true returns an empty table rather than ''
 587 #   sizecol -- if true include a human-readable size column
 588 #   typecol -- if true include type column with hover info
 589 #   changed -- if true include a changed and idle column
 590 sub projects_html_list {
 591         my $options = {};
 592         if (defined($_[0]) && ref($_[0]) eq 'HASH') {
 593                 $options = shift;
 594         }
 595         return '' unless @_ || (defined($options->{emptyok}) && $options->{emptyok});
 596         require Girocco::Project;
 597         my $count = 0;
 598         my $target = '';
 599         $target = " target=\""._escapeHTML($options->{target})."\""
 600                 if defined($options->{target});
 601         my $withsize = defined($options->{sizecol}) && $options->{sizecol};
 602         my $withtype = defined($options->{typecol}) && $options->{typecol};
 603         my $withchanged = defined($options->{changed}) && $options->{changed};
 604         my $sizehead = '';
 605         $sizehead = substr(<<EOT, 0, -1) if $withsize;
 606 <th class="sizecol"><span class="hover">Size<span><span class="head" _data="Size"></span
 607 /><span class="none" /><br />(</span>Fork size excludes objects borrowed from the parent.<span class="none">)</span></span></span></th
 608 >
 609 EOT
 610         my $typehead = '';
 611         $typehead = '<th>Type</th>' if $withtype;
 612         my $chghead = '';
 613         $chghead = substr(<<EOT, 0, -1) if $withchanged;
 614 <th><span class="hover">Changed<span><span class="head" _data="Changed"></span
 615 /><span class="none" /><br />(</span>The last time a ref change was received by this site.<span class="none">)</span></span></span></th
 616 ><th><span class="hover">Idle<span><span class="head" _data="Idle"></span
 617 /><span class="none" /><br />(</span>The most recent committer time in <i>refs/heads</i>.<span class="none">)</span></span></span></th
 618 >
 619 EOT
 620         my $html = <<EOT;
 621 <table class='projectlist'><tr valign="top" align="left"><th>Project</th>$sizehead$typehead$chghead<th class="desc">Description</th></tr>
 622 EOT
 623         my $trclass = ' class="odd"';
 624         foreach (sort({lc($a) cmp lc($b)} @_)) {
 625                 if (Girocco::Project::does_exist($_, 1)) {
 626                         my $proj = Girocco::Project->load($_);
 627                         my $projname = $proj->{name}.".git";
 628                         my $projdesc = $proj->{desc}||'';
 629                         utf8::decode($projdesc) if utf8::valid($projdesc);
 630                         my $sizecol = '';
 631                         if ($withsize) {
 632                                 my $psize = $proj->{reposizek};
 633                                 $psize = undef unless defined($psize) && $psize =~ /^\d+$/;
 634                                 $psize = 0 if !defined($psize) && $proj->is_empty;
 635                                 if (!defined($psize)) {
 636                                         $psize = 'unknown';
 637                                 } elsif (!$psize) {
 638                                         $psize = 'empty';
 639                                 } else {
 640                                         $psize = human_size($psize * 1024);
 641                                         $psize =~ s/ /\&#160;/g;
 642                                 }
 643                                 $sizecol = '<td class="sizecol">'.$psize.'</td>';
 644                         }
 645                         my $typecol = '';
 646                         if ($withtype) {
 647                                 if ($proj->{mirror}) {
 648                                         my $url = _escapeHTML($proj->{url});
 649                                         $typecol = substr(<<EOT, 0, -1);
 650 <td class="type"><span class="hover">mirror<span class="nowrap"><span class="before" _data="$url"><span class="none"> <a href="$url" rel="nofollow">(URL)</a></span></span></span></span></td>
 651 EOT
 652                                 } else {
 653                                         my $users = @{$proj->{users}};
 654                                         $users .= ' user';
 655                                         $users .= 's' unless @{$proj->{users}} == 1;
 656                                         my $userlist = join(', ', sort({lc($a) cmp lc($b)} @{$proj->{users}}));
 657                                         my $spncls = length($userlist) > 25 ? '' : ' class="nowrap"';
 658                                         $typecol = $userlist ? substr(<<EOT, 0, -1) : substr(<<EOT, 0, -1);
 659 <td class="type"><span class="hover">$users<span$spncls><br class="none" />$userlist</span></span></td>
 660 EOT
 661 <td class="type">$users</td>
 662 EOT
 663                                 }
 664                         }
 665                         my $changecol = '';
 666                         if ($withchanged) {
 667                                 my $rel = '';
 668                                 my $changetime = $proj->{lastchange};
 669                                 if ($changetime) {
 670                                         my ($ts, $tz);
 671                                         $ts = parse_rfc2822_date($changetime, \$tz);
 672                                         my $ct = _strftime("%Y-%m-%d %T %z", $ts, $tz);
 673                                         $rel = "<span class=\"hover\">" .
 674                                                 _rel_age(time - $ts) .
 675                                                 "<span class=\"nowrap\"><span class=\"before\" _data=\"$changetime\"></span><span class=\"none\"><br />$ct</span></span></span>";
 676                                 } else {
 677                                         $rel = "no commits";
 678                                 }
 679                                 $changecol = substr(<<EOT, 0, -1);
 680 <td class="change">$rel</td>
 681 EOT
 682                                 my $idletime = $proj->{lastactivity};
 683                                 my ($idlesecs, $tz);
 684                                 $idlesecs = parse_any_date($idletime, \$tz) if $idletime;
 685                                 if ($idlesecs) {
 686                                         my $idle2822 = _strftime("%a, %d %b %Y %T %z", $idlesecs, $tz);
 687                                         my $ct = _strftime("%Y-%m-%d %T %z", $idlesecs, $tz);
 688                                         $rel = "<span class=\"hover\">" .
 689                                                 _rel_idle(time - $idlesecs) .
 690                                                 "<span class=\"nowrap\"><span class=\"before\" _data=\"$idle2822\"></span><span class=\"none\"><br />$ct</span></span></span>";
 691                                 } else {
 692                                         $rel = "no commits";
 693                                 }
 694                                 $changecol .= substr(<<EOT, 0, -1);
 695 <td class="idle">$rel</td>
 696 EOT
 697                         }
 698                         $html .= <<EOT;
 699 <tr valign="top"$trclass><td><a href="@{[url_path($Girocco::Config::gitweburl)]}/$projname"$target
 700 >@{[_escapeHTML($projname)]}</td>$sizecol$typecol$changecol<td>@{[_escapeHTML($projdesc)]}</td></tr>
 701 EOT
 702                         $trclass = $trclass ? '' : ' class="odd"';
 703                         ++$count;
 704                 }
 705         }
 706         $html .= <<EOT;
 707 </table>
 708 EOT
 709         return ($count || (defined($options->{emptyok}) && $options->{emptyok})) ? $html : '';
 710 }
 711
 712 my %_month_names;
 713 BEGIN {
 714         %_month_names = (
 715                 jan => 0, feb => 1, mar => 2, apr => 3, may => 4, jun => 5,
 716                 jul => 6, aug => 7, sep => 8, oct => 9, nov => 10, dec => 11
 717         );
 718 }
 719
 720 # Should be in "date '+%a, %d %b %Y %T %z'" format as saved to lastgc, lastrefresh and lastchange
 721 # The leading "%a, " is optional, returns undef if unrecognized date.  This is also known as
 722 # RFC 2822 date format and git's '%cD', '%aD' and --date=rfc2822 format.
 723 # If the second argument is a SCALAR ref, its value will be set to the TZ offset in seconds
 724 sub parse_rfc2822_date {
 725         my $dstr = shift || '';
 726         my $tzoff = shift || '';
 727         $dstr = $1 if $dstr =~/^[^\s]+,\s*(.*)$/;
 728         return undef unless $dstr =~
 729                 /^\s*(\d{1,2})\s+([A-Za-z]{3})\s+(\d{4})\s+(\d{1,2}):(\d{2}):(\d{2})\s+([+-]\d{4})\s*$/;
 730         my ($d,$b,$Y,$H,$M,$S,$z) = ($1,$2,$3,$4,$5,$6,$7);
 731         my $m = $_month_names{lc($b)};
 732         return undef unless defined($m);
 733         my $seconds = timegm(0+$S, 0+$M, 0+$H, 0+$d, 0+$m, 0+$Y);
 734         my $offset = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
 735         $offset = -$offset if substr($z,0,1) eq '-';
 736         $$tzoff = $offset if ref($tzoff) eq 'SCALAR';
 737         return $seconds - $offset;
 738 }
 739
 740 # Will parse any supported date format.  Actually there are three formats
 741 # currently supported:
 742 #   1. RFC 2822 (uses parse_rfc2822_date)
 743 #   2. RFC 3339 / ISO 8601 (T may be ' ' or '_', 'Z' is optional or may be 'UTC', ':' optional in TZ)
 744 #   3. Same as #2 except no colons or hyphens allowed and hours MUST be 2 digits
 745 #   4. unix seconds since epoch with optional +/- trailing TZ (may not have a ':')
 746 # Returns undef if unsupported date.
 747 # If the second argument is a SCALAR ref, its value will be set to the TZ offset in seconds
 748 sub parse_any_date {
 749         my $dstr = shift || '';
 750         my $tzoff = shift || '';
 751         if ($dstr =~ /^\s*([-+]?\d+)(?:\s+([-+]\d{4}))?\s*$/) {
 752                 # Unix timestamp
 753                 my $ts = 0 + $1;
 754                 my $off = 0;
 755                 if ($2) {
 756                         my $z = $2;
 757                         $off = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
 758                         $off = -$off if substr($z,0,1) eq '-';
 759                 }
 760                 $$tzoff = $off if ref($tzoff) eq 'SCALAR';
 761                 return $ts;
 762         }
 763         if ($dstr =~ /^\s*(\d{4})-(\d{2})-(\d{2})[Tt _](\d{1,2}):(\d{2}):(\d{2})(?:[ _]?([Zz]|[Uu][Tt][Cc]|(?:[-+]\d{1,2}:?\d{2})))?\s*$/ ||
 764             $dstr =~ /^\s*(\d{4})(\d{2})(\d{2})[Tt _](\d{2})(\d{2})(\d{2})(?:[ _]?([Zz]|[Uu][Tt][Cc]|(?:[-+]\d{2}\d{2})))?\s*$/) {
 765                 my ($Y,$m,$d,$H,$M,$S,$z) = ($1,$2,$3,$4,$5,$6,$7||'');
 766                 my $seconds = timegm(0+$S, 0+$M, 0+$H, 0+$d, $m-1, 0+$Y);
 767                 defined($z) && $z ne '' or $z = 'Z';
 768                 $z = uc($z);
 769                 $z =~ s/://;
 770                 substr($z,1,0) = '0' if length($z) == 4;
 771                 my $off = 0;
 772                 if ($z ne 'Z' && $z ne 'UTC') {
 773                         $off = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
 774                         $off = -$off if substr($z,0,1) eq '-';
 775                 }
 776                 $$tzoff = $off if ref($tzoff) eq 'SCALAR';
 777                 return $seconds - $off;
 778         }
 779         return parse_rfc2822_date($dstr, $tzoff);
 780 }
 781
 782 # Input is a number such as a minute interval
 783 # Return value is a random number between the input and 1.25*input
 784 # This can be used to randomize the update and gc operations a bit to avoid
 785 # having them all end up all clustered together
 786 sub rand_adjust {
 787         my $input = shift || 0;
 788         return $input unless $input;
 789         return $input + int(rand(0.25 * $input));
 790 }
 791
 792 # Open a pipe to a new sendmail process.  The '-i' option is always passed to
 793 # the new process followed by any addtional arguments passed in.  Note that
 794 # the sendmail process is only expected to understand the '-i', '-t' and '-f'
 795 # options.  Using any other options via this function is not guaranteed to work.
 796 # A list of recipients may follow the options.  Combining a list of recipients
 797 # with the '-t' option is not recommended.
 798 sub sendmail_pipe {
 799         return undef unless @_;
 800         die "\$Girocco::Config::sendmail_bin is unset or not executable!\n"
 801                 unless $Girocco::Config::sendmail_bin && -x $Girocco::Config::sendmail_bin;
 802         my $result = open(my $pipe, '|-', $Girocco::Config::sendmail_bin, '-i', @_);
 803         return $result ? $pipe : undef;
 804 }
 805
 806 # Open a pipe that works similarly to a mailer such as /usr/bin/mail in that
 807 # if the first argument is '-s', a subject line will be automatically added
 808 # (using the second argument as the subject).  Any remaining arguments are
 809 # expected to be recipient addresses that will be added to an explicit To:
 810 # line as well as passed on to sendmail_pipe.  In addition an
 811 # "Auto-Submitted: auto-generated" header is always added as well as a suitable
 812 # "From:" header.
 813 sub mailer_pipe {
 814         my $subject = undef;
 815         if (@_ >= 2 && $_[0] eq '-s') {
 816                 shift;
 817                 $subject = shift;
 818         }
 819         my $tolist = join(", ", @_);
 820         unshift(@_, '-f', $Girocco::Config::sender) if $Girocco::Config::sender;
 821         my $pipe = sendmail_pipe(@_);
 822         if ($pipe) {
 823                 print $pipe "From: \"$Girocco::Config::name\" ",
 824                         "($Girocco::Config::title) ",
 825                         "<$Girocco::Config::admin>\n";
 826                 print $pipe "To: $tolist\n";
 827                 print $pipe "Subject: $subject\n" if defined($subject);
 828                 print $pipe "MIME-Version: 1.0\n";
 829                 print $pipe "Content-Type: text/plain; charset=utf-8; format=fixed\n";
 830                 print $pipe "Content-Transfer-Encoding: 8bit\n";
 831                 print $pipe "X-Girocco: $Girocco::Config::gitweburl\n"
 832                         unless $Girocco::Config::suppress_x_girocco;
 833                 print $pipe "Auto-Submitted: auto-generated\n";
 834                 print $pipe "\n";
 835         }
 836         return $pipe;
 837 }
 838
 839 sub _goodval {
 840         my $val = shift;
 841         return undef unless defined($val);
 842         $val =~ s/[\r\n]+$//s;
 843         return undef unless $val =~ /^\d+$/;
 844         $val = 0 + $val;
 845         return undef unless $val >= 1;
 846         return $val;
 847 }
 848
 849 # Returns the number of "online" cpus or undef if undetermined
 850 sub online_cpus {
 851         my @confcpus = $^O eq "linux" ?
 852                 qw(_NPROCESSORS_ONLN NPROCESSORS_ONLN) :
 853                 qw(NPROCESSORS_ONLN _NPROCESSORS_ONLN) ;
 854         my $cpus = _goodval(get_cmd('getconf', $confcpus[0]));
 855         return $cpus if $cpus;
 856         $cpus = _goodval(get_cmd('getconf', $confcpus[1]));
 857         return $cpus if $cpus;
 858         if ($^O ne "linux") {
 859                 my @sysctls = qw(hw.ncpu);
 860                 unshift(@sysctls, qw(hw.availcpu)) if $^O eq "darwin";
 861                 foreach my $mib (@sysctls) {
 862                         $cpus = _goodval(get_cmd('sysctl', '-n', $mib));
 863                         return $cpus if $cpus;
 864                 }
 865         }
 866         return undef;
 867 }
 868
 869 # Returns the system page size in bytes or undef if undetermined
 870 # This should never fail on a POSIX system
 871 sub sys_pagesize {
 872         use POSIX ":unistd_h";
 873         my $pagesize = sysconf(_SC_PAGESIZE);
 874         return undef unless defined($pagesize) && $pagesize =~ /^\d+$/;
 875         $pagesize = 0 + $pagesize;
 876         return undef unless $pagesize >= 256;
 877         return $pagesize;
 878 }
 879
 880 # Returns the amount of available physical memory in bytes
 881 # This may differ from the actual amount of physical memory installed
 882 # Returns undef if this cannot be determined
 883 sub sys_memsize {
 884         my $pagesize = sys_pagesize;
 885         if ($pagesize && $^O eq "linux") {
 886                 my $pages = _goodval(get_cmd('getconf', '_PHYS_PAGES'));
 887                 return $pagesize * $pages if $pages;
 888         }
 889         if ($^O ne "linux") {
 890                 my @sysctls = qw(hw.physmem64);
 891                 unshift(@sysctls, qw(hw.memsize)) if $^O eq "darwin";
 892                 foreach my $mib (@sysctls) {
 893                         my $memsize = _goodval(get_cmd('sysctl', '-n', $mib));
 894                         return $memsize if $memsize;
 895                 }
 896                 my $memsize32 = _goodval(get_cmd('sysctl', '-n', 'hw.physmem'));
 897                 return $memsize32 if $memsize32 && $memsize32 <= 2147483647;
 898                 if ($pagesize) {
 899                         my $pages = _goodval(get_cmd('sysctl', '-n', 'hw.availpages'));
 900                         return $pagesize * $pages if $pages;
 901                 }
 902                 return 2147483647 + 1 if $memsize32;
 903         }
 904         return undef;
 905 }
 906
 907 sub _get_max_conf_suffixed_size {
 908         my $conf = shift;
 909         return undef unless defined $conf && $conf =~ /^(\d+)([kKmMgG]?)$/;
 910         my ($val, $suffix) = (0+$1, lc($2));
 911         $val *= 1024 if $suffix eq 'k';
 912         $val *= 1024 * 1024 if $suffix eq 'm';
 913         $val *= 1024 * 1024 * 1024 if $suffix eq 'g';
 914         return $val;
 915 }
 916
 917 sub _make_suffixed_size {
 918         my $size = shift;
 919         return $size if $size % 1024;
 920         $size /= 1024;
 921         return "${size}k" if $size % 1024;
 922         $size /= 1024;
 923         return "${size}m" if $size % 1024;
 924         $size /= 1024;
 925         return "${size}g";
 926 }
 927
 928 # Return the value to pass to --window-memory= for git repack
 929 # If the system memory or number of CPUs cannot be determined, returns "1g"
 930 # Otherwise returns one third the available memory divided by the number of CPUs
 931 # but never more than 1 gigabyte or max_gc_window_memory_size.
 932 sub calc_windowmemory {
 933         my $cpus = online_cpus;
 934         my $memsize = sys_memsize;
 935         my $max = 1024 * 1024 * 1024;
 936         if ($cpus && $memsize) {
 937                 $max = int($memsize / 3 / $cpus);
 938                 $max = 1024 * 1024 * 1024 if $max >= 1024 * 1024 * 1024;
 939         }
 940         my $maxconf = _get_max_conf_suffixed_size($Girocco::Config::max_gc_window_memory_size);
 941         $max = $maxconf if defined($maxconf) && $maxconf && $max > $maxconf;
 942         return _make_suffixed_size($max);
 943 }
 944
 945 # Return the value to set as core.bigFileThreshold for git repack
 946 # If the system memory cannot be determined, returns "256m"
 947 # Otherwise returns the available memory divided by 16
 948 # but never more than 512 megabytes or max_gc_big_file_threshold_size.
 949 sub calc_bigfilethreshold {
 950         my $memsize = sys_memsize;
 951         my $max = 256 * 1024 * 1024;
 952         if ($memsize) {
 953                 $max = int($memsize / 16);
 954                 $max = 512 * 1024 * 1024 if $max >= 512 * 1024 * 1024;
 955         }
 956         my $maxconf = _get_max_conf_suffixed_size($Girocco::Config::max_gc_big_file_threshold_size);
 957         $max = $maxconf if defined($maxconf) && $maxconf && $max > $maxconf;
 958         return _make_suffixed_size($max);
 959 }
 960
 961 # Return the value to use when deciding whether or not to re-calculate object deltas
 962 # If there are no more than this many objects then deltas will be recomputed in
 963 # order to create more efficient pack files.  The new_delta_threshold value
 964 # is constrained to be at least 1000 * cpu cores and no more than 100000.
 965 # The default is sys_memsize rounded up to the nearest multiple of 256 MB and
 966 # then 5000 per 256 MB or 50000 if we cannot determine memory size but never
 967 # more than 100000 or less than 1000 * cpu cores.
 968 sub calc_redeltathreshold {
 969         my $cpus = online_cpus || 1;
 970         if (defined($Girocco::Config::new_delta_threshold) &&
 971             $Girocco::Config::new_delta_threshold =~ /^\d+/) {
 972                 my $ndt = 0 + $Girocco::Config::new_delta_threshold;
 973                 if ($ndt >= $cpus * 1000) {
 974                         return $ndt <= 100000 ? $ndt : 100000;
 975                 }
 976         }
 977         my $calcval = 50000;
 978         my $memsize = sys_memsize;
 979         if ($memsize) {
 980                 my $quantum = 256 * 1024 * 1024;
 981                 $calcval = 5000 * int(($memsize + ($quantum - 1)) / $quantum);
 982                 $calcval = 1000 * $cpus if $calcval < 1000 * $cpus;
 983                 $calcval = 100000 if $calcval > 100000;
 984         }
 985         return $calcval;
 986 }
 987
 988 # $1 => thing to test
 989 # $2 => optional directory, if given and -e "$2/$1$3", then return false
 990 # $3 => optional, defaults to ''
 991 sub has_reserved_suffix {
 992         no warnings; # avoid silly 'unsuccessful stat on filename with \n' warning
 993         my ($name, $dir, $ext) = @_;
 994         $ext = '' unless defined $ext;
 995         return 0 unless defined $name && $name =~ /\.([^.]+)$/;
 996         return 0 unless exists $Girocco::Config::reserved_suffixes{lc($1)};
 997         return 0 if defined $dir && -e "$dir/$name$ext";
 998         return 1;
 999 }
1000
1001 # mostly undoes effect of `use CGI::Carp qw(fatalsToBrowser);`
1002 # mostly undoes effect of `use CGI::Carp qw(warningsToBrowser);`
1003 sub noFatalsToBrowser {
1004         delete $SIG{__DIE__};
1005         delete $SIG{__WARN__};
1006         undef *CORE::GLOBAL::die;
1007         *CORE::GLOBAL::die = sub {
1008                 no warnings;
1009                 my $ec = $! || ($? >> 8) || 255;
1010                 my (undef, $fn, $li) = caller(0);
1011                 my $loc = " at " . $fn . " line " . $li . ".\n";
1012                 my $msg = "";
1013                 $msg = join("", @_) if @_;
1014                 $msg = "Died" if $msg eq "";
1015                 $msg .= $loc unless $msg =~ /\n$/;
1016                 die $msg if $^S;
1017                 printf STDERR "%s", $msg;
1018                 exit($ec);
1019         };
1020         undef *CORE::GLOBAL::warn;
1021         *CORE::GLOBAL::warn = sub {
1022                 no warnings;
1023                 my (undef, $fn, $li) = caller(0);
1024                 my $loc = " at " . $fn . " line " . $li . ".\n";
1025                 my $msg = "";
1026                 $msg = join("", @_) if @_;
1027                 $msg = "Warning: something's wrong" if $msg eq "";
1028                 $msg .= $loc unless $msg =~ /\n$/;
1029                 printf STDERR "%s", $msg;
1030         };
1031 }
1032
1033 # mimics Git's symref reading but only for HEAD
1034 # returns undef on failure otherwise an string that is
1035 # either an all-hex (lowercase) value or starts with "refs/"
1036 sub read_HEAD_ref {
1037         my $headpath = $_[0] . "/HEAD";
1038         if (-l $headpath) {
1039                 my $rl = readlink($headpath);
1040                 return defined($rl) && $rl =~ m,^refs/[^\x00-\x1f \x7f~^:\\*?[]+$, ? $rl : undef;
1041         }
1042         open my $fd, '<', $headpath or return undef;
1043         my $hv;
1044         {
1045                 local $/ = undef;
1046                 $hv = <$fd>;
1047         }
1048         close $fd;
1049         defined($hv) or return undef;
1050         chomp $hv;
1051         $hv =~ m,^ref:\s*(refs/[^\x00-\x1f \x7f~^:\\*?[]+)$, and return $1;
1052         $hv =~ m/^[0-9a-fA-F]{40,}$/ and return lc($hv);
1053         return undef;
1054 }
1055
1056 # same as read_HEAD_ref but returns undef
1057 # unless the result starts with "refs/"
1058 sub read_HEAD_symref {
1059         my $hv = read_HEAD_ref(@_);
1060         return defined($hv) && $hv =~ m,^refs/., ? $hv : undef;
1061 }
1062
1063 my $cf_unesc;
1064 BEGIN {
1065         my %escvals = (
1066                 b    => "\b",
1067                 t    => "\t",
1068                 n    => "\n",
1069                 '"'  => '"',
1070                 '\\' => '\\'
1071         );
1072         $cf_unesc = sub {
1073                 $_[0] =~ s/\\([btn\042\\])/$escvals{$1}/g;
1074                 $_[0];
1075         };
1076 }
1077
1078 # mimics Git's config.c git_parse_source function behavior
1079 # returns array of arrayref of key and value
1080 # except that valueless booleans have a value of undef
1081 sub read_config_file {
1082         local $_;
1083         my ($fn, $warn) = @_;
1084         my $li = 0;
1085         my $section = "";
1086         my @vals = ();
1087         open my $fh, '<', $fn or
1088                 $warn && warn("could not open \"$fn\": $!\n"), return(undef);
1089         binmode($fh);
1090         my $bad = sub {
1091                 close $fh;
1092                 warn "bad config line $li in file $fn\n" if $warn;
1093                 return undef;
1094         };
1095         while (<$fh>) {
1096                 ++$li;
1097                 s/(?:\r\n|\n)$//;
1098                 $_ = to_utf8($_);
1099                 s/^\x{feff}// if $li == 1;
1100                 utf8::encode($_);
1101                 if (/^\s*\[/gc) {
1102                         if (/\G([.a-zA-Z0-9-]+)\]/gc) {
1103                                 $section = lc($1) . ".";
1104                         } elsif (/\G([.a-zA-Z0-9-]*)\s+"((?:[^\042\\\n]|\\.)*)"\]/gc) {
1105                                 $section = lc($1) . "." .
1106                                         &{sub{my $x=shift; $x =~ s/\\(.)/$1/g; $x}}($2) . ".";
1107                         } else {
1108                                 return &$bad;
1109                         }
1110                 }
1111                 /\G\s+/gc;
1112                 next if /\G(?:[;#]|$)/;
1113                 if (/\G([a-zA-Z][a-zA-Z0-9-]*)[ \t]*/gc) {
1114                         my $k = $section . lc($1);
1115                         my $v;
1116                         if (/\G$/) {
1117                                 $v = undef;
1118                         } elsif (/\G=\s*/gc) {
1119                                 $v = "";
1120                                 my $qt = 0;
1121                                 {
1122                                         if (/\G$/) {
1123                                                 last if !$qt;
1124                                                 return &$bad;
1125                                         }
1126                                         if (!$qt && /\G((?:[^"\\\n;#]|\\[btn"\\])+)/gc) {
1127                                                 my $a = $1;
1128                                                 if (/\G[;#]/) {
1129                                                         $_ = "";
1130                                                         $a =~ s/\s+$//;
1131                                                 }
1132                                                 $a =~ s/\s/ /g;
1133                                                 $v .= &$cf_unesc($a);
1134                                         } elsif ($qt && /\G((?:[^"\\\n]|\\[btn"\\])+)/gc) {
1135                                                 my $a = $1;
1136                                                 $v .= &$cf_unesc($a);
1137                                         } elsif (/\G\042/gc) {
1138                                                 $qt = !$qt;
1139                                         } elsif (!$qt && /\G[;#]/gc) {
1140                                                 $_ = "";
1141                                         } elsif (/\G\\$/) {
1142                                                 $_ = <$fh>;
1143                                                 if (defined($_)) {
1144                                                         ++$li;
1145                                                         s/(?:\r\n|\n)$//;
1146                                                         $_ = to_utf8($_, 1);
1147                                                         /^\s+/gc unless $v ne "" || $qt;
1148                                                 } else {
1149                                                         $_ = "";
1150                                                 }
1151                                         } else {
1152                                                 return &$bad;
1153                                         }
1154                                         redo;
1155                                 }
1156                         } else {
1157                                 return &$bad;
1158                         }
1159                         push(@vals, [$k, $v]);
1160                 } else {
1161                         return &$bad;
1162                 }
1163         }
1164         close $fh;
1165         return \@vals;
1166 }
1167
1168 # Same as read_config_file except that a hashref is returned and
1169 # subsequent same-key-name values replace earlier ones.
1170 # Also valueless booleans are given the value 1
1171 sub read_config_file_hash {
1172         my $result = read_config_file(@_);
1173         return undef unless defined($result);
1174         my %config = map {($$_[0], defined($$_[1])?$$_[1]:1)} @$result;
1175         return \%config;
1176 }
1177
1178 # similar to Git's test except that GIT_OBJECT_DIRECTORY is ignored
1179 sub is_git_dir {
1180         my $gd = shift;
1181         defined($gd) && $gd ne "" && -d $gd or return undef;
1182         -d "$gd/objects" && -x "$gd/objects" or return 0;
1183         -d "$gd/refs" && -x "$gd/refs" or return 0;
1184         if (-l "$gd/HEAD") {
1185                 my $rl = readlink("$gd/HEAD");
1186                 defined($rl) && $rl =~ m,^refs/., or return 0;
1187                 -e "$gd/HEAD" or return 1;
1188         }
1189         open my $fd, '<', "$gd/HEAD" or return 0;
1190         my $hv;
1191         {
1192                 local $/;
1193                 $hv = <$fd>;
1194         }
1195         close $fd;
1196         defined $hv or return 0;
1197         chomp $hv;
1198         $hv =~ m,^ref:\s*refs/., and return 1;
1199         return $hv =~ /^[0-9a-f]{40}/;
1200 }
1201
1202 # Returns 0 for false, 1 for true, undef for unrecognized or undef
1203 # Unless the optional second argument is true in which case undef returns 1
1204 sub git_bool {
1205         defined($_[0]) or return $_[1] ? 1 : undef;
1206         my $v = lc($_[0]);
1207         return 0 if $v eq 'false' || $v eq 'off' || $v eq 'no' || $v eq '' || $v =~ /^[-+]?0+$/;
1208         return 1 if $v eq 'true' || $v eq 'on' || $v eq 'yes' || $v =~ /^[-+]?0*[1-9][0-9]*$/;
1209         return undef;
1210 }
1211
1212 # Returns a PATH properly prefixed which guarantees that Git is found and the
1213 # basedir/bin utilities are found as intended.  $ENV{PATH} is LEFT UNCHANGED!
1214 # Caller is responsible for assigning result to $ENV{PATH} or otherwise
1215 # arranging for it to be used.  If $ENV{PATH} already has the proper prefix
1216 # then it's returned as-is (making this function idempotent).
1217 # Will die if it cannot determine a suitable full PATH.
1218 # Result is cached so all calls after the first are practically free.
1219 my $var_git_exec_path;
1220 sub util_path {
1221         if (!defined($var_git_exec_path)) {
1222                 defined($Girocco::Config::basedir) && $Girocco::Config::basedir ne "" &&
1223                 -d $Girocco::Config::basedir && -r _ && -x _ or
1224                         die "invalid \$Girocco::Config::basedir setting: $Girocco::Config::basedir\n";
1225                 my $varsfile = $Girocco::Config::basedir . "/shlib_vars.sh";
1226                 if (-f $varsfile && -r _) {
1227                         my $vars;
1228                         if (open $vars, '<', $varsfile) {
1229                                 # last value for var_git_exec_path wins
1230                                 while (<$vars>) {
1231                                         chomp;
1232                                         substr($_, 0, 19) eq "var_git_exec_path=\"" or next;
1233                                         substr($_, -1, 1) eq "\"" or next;
1234                                         my $xd = substr($_, 19, -1);
1235                                         $var_git_exec_path = $xd if -d $xd && -r _ && -x _;
1236                                 }
1237                                 close $vars;
1238                         }
1239                 }
1240                 if (!defined($var_git_exec_path)) {
1241                         my $xd = get_git("--exec-path");
1242                         $var_git_exec_path = $xd if defined($xd) &&
1243                                 (chomp $xd, $xd) ne "" && -d $xd && -r _ && -x _;
1244                 }
1245                 defined($var_git_exec_path) or
1246                         die "could not determine \$(git --exec-path) value\n"
1247         }
1248         my $prefix = "$var_git_exec_path:$Girocco::Config::basedir/bin:";
1249         if (substr($ENV{PATH}, 0, length($prefix)) eq $prefix) {
1250                 return $ENV{PATH};
1251         } else {
1252                 return $prefix . $ENV{PATH};
1253         }
1254 }
1255
1256 # Note that Perl performs a "shellish" test in the Perl_do_exec3 function from doio.c,
1257 # but it has slightly different semantics in that whitespace does not automatically
1258 # make something "shellish".  The semantics used here more closely match Git's
1259 # semantics so that Girocco will provide an interpretation more similar to Git's.
1260 sub is_shellish {
1261         return unless defined(local $_ = shift);
1262         return 1 if m#[][\$&*(){}'";:=\\|?<>~`\#\s]#; # contains metacharacters
1263         return 0; # probably not shellish
1264 }
1265
1266 # Works just like the shlib.sh function git_add_config
1267 # except it takes two arguments, first the variable name, second the value
1268 # For example: git_add_config("gc.auto", "0")
1269 # No extra quoting is performed!
1270 # If the name or value requires special quoting, it must be provided by the caller!
1271 # Note this function will only be effective when running Git 1.7.3 or later
1272 sub git_add_config {
1273         my ($name, $val) = @_;
1274         defined($name) && defined($val) or return;
1275         $name ne "" or return;
1276         my $gcp = $ENV{GIT_CONFIG_PARAMETERS};
1277         defined($gcp) or $gcp = '';
1278         $gcp eq "" or $gcp = $gcp . " ";
1279         $gcp .= "'" . $name . '=' . $val . "'";
1280         $ENV{GIT_CONFIG_PARAMETERS} = $gcp;
1281 }
1282
1283 1;