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 Girocco::ConfigUtil;
   9 use Girocco::TimedToken;
  10 use Girocco::ValidUtil;
  11 use Time::Local;
  12 use Scalar::Util qw(looks_like_number);
  13 use Encode ();
  14
  15 BEGIN {
  16         use base qw(Exporter);
  17         our @EXPORT = qw(get_git scrypt jailed_file sendmail_pipe mailer_pipe
  18                          lock_file unlock_file valid_tag rand_adjust
  19                          filedb_atomic_append filedb_atomic_edit filedb_grep
  20                          filedb_atomic_grep valid_email valid_email_multi
  21                          valid_repo_url valid_web_url url_base url_path url_server
  22                          projects_html_list parse_rfc2822_date parse_any_date
  23                          extract_url_hostname is_dns_hostname is_our_hostname
  24                          get_cmd online_cpus sys_pagesize sys_memsize
  25                          calc_windowmemory to_utf8 capture_command human_size
  26                          calc_bigfilethreshold has_reserved_suffix human_duration
  27                          noFatalsToBrowser calc_redeltathreshold
  28                          clean_email_multi read_HEAD_symref read_config_file
  29                          read_config_file_hash is_git_dir git_bool util_path
  30                          is_shellish read_HEAD_ref git_add_config to_json
  31                          json_bool from_json ref_indicator get_token_key
  32                          get_timed_token get_token_field check_timed_token
  33                          valid_branch_name get_project_from_dir
  34                          get_git_chomp check_readonly is_readonly);
  35 }
  36
  37 BEGIN {require "Girocco/extra/capture_command.pl"}
  38
  39 # Return the entire output sent to stdout from running a command
  40 # Any output the command sends to stderr is discarded
  41 # Returns undef if there was an error running the command (see $!)
  42 sub get_cmd {
  43         my ($status, $result) = capture_command(1, undef, @_);
  44         return defined($status) && $status == 0 ? $result : undef;
  45 }
  46
  47 # Same as get_cmd except configured git binary is automatically provided
  48 # as the first argument to get_cmd
  49 sub get_git {
  50         return get_cmd($Girocco::Config::git_bin, @_);
  51 }
  52
  53 # Same as get_git except that the result (if not undef) is chomp'd before
  54 # returning it
  55 sub get_git_chomp {
  56         my $ans = get_git(@_);
  57         defined($ans) and chomp $ans;
  58         return $ans;
  59 }
  60
  61 sub scrypt {
  62         my ($pwd) = @_;
  63         crypt($pwd||'', join ('', ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]));
  64 }
  65
  66 sub jailed_file {
  67         my ($filename) = @_;
  68         $filename =~ s,^/,,;
  69         $Girocco::Config::chroot."/$filename";
  70 }
  71
  72 sub lock_file {
  73         my ($path) = @_;
  74
  75         $path .= '.lock';
  76
  77         use Errno qw(EEXIST);
  78         use Fcntl qw(O_WRONLY O_CREAT O_EXCL);
  79         use IO::Handle;
  80         my $handle = new IO::Handle;
  81
  82         unless (sysopen($handle, $path, O_WRONLY|O_CREAT|O_EXCL)) {
  83                 my $cnt = 0;
  84                 while (not sysopen($handle, $path, O_WRONLY|O_CREAT|O_EXCL)) {
  85                         ($! == EEXIST) or die "$path open failed: $!";
  86                         ($cnt++ < 16) or die "$path open failed: cannot open lockfile";
  87                         sleep(1);
  88                 }
  89         }
  90         # XXX: filedb-specific
  91         chmod 0664, $path or die "$path g+w failed: $!";
  92
  93         $handle;
  94 }
  95
  96 sub _is_passwd_file {
  97         return defined($_[0]) && $_[0] eq jailed_file('/etc/passwd');
  98 }
  99
 100 sub _run_update_pwd_db {
 101         my ($path, $updatearg) = @_;
 102         my @cmd = ($Girocco::Config::basedir.'/bin/update-pwd-db', "$path");
 103         push(@cmd, $updatearg) if $updatearg;
 104         system(@cmd) == 0 or die "update-pwd-db failed: $?";
 105 }
 106
 107 sub unlock_file {
 108         my ($path, $noreplace, $updatearg) = @_;
 109
 110         if (!$noreplace) {
 111                 _run_update_pwd_db("$path.lock", $updatearg)
 112                         if $Girocco::Config::update_pwd_db && _is_passwd_file($path);
 113                 rename "$path.lock", $path or die "$path unlock failed: $!";
 114         } else {
 115                 unlink "$path.lock" or die "$path unlock failed: $!";
 116         }
 117 }
 118
 119 sub filedb_atomic_append {
 120         my ($file, $line, $updatearg) = @_;
 121         my $id = 65536;
 122
 123         open my $src, '<', $file or die "$file open for reading failed: $!";
 124         my $dst = lock_file($file);
 125
 126         while (<$src>) {
 127                 my $aid = (split /:/)[2];
 128                 $id = $aid + 1 if ($aid >= $id);
 129
 130                 print $dst $_ or die "$file(l) write failed: $!";
 131         }
 132
 133         $line =~ s/\\i/$id/g;
 134         print $dst "$line\n" or die "$file(l) write failed: $!";
 135
 136         close $dst or die "$file(l) close failed: $!";
 137         close $src;
 138
 139         unlock_file($file, 0, $updatearg);
 140
 141         $id;
 142 }
 143
 144 sub filedb_atomic_edit {
 145         my ($file, $fn, $updatearg) = @_;
 146
 147         open my $src, '<', $file or die "$file open for reading failed: $!";
 148         my $dst = lock_file($file);
 149
 150         while (<$src>) {
 151                 print $dst $fn->($_) or die "$file(l) write failed: $!";
 152         }
 153
 154         close $dst or die "$file(l) close failed: $!";
 155         close $src;
 156
 157         unlock_file($file, 0, $updatearg);
 158 }
 159
 160 sub filedb_atomic_grep {
 161         my ($file, $fn) = @_;
 162         my @results = ();
 163
 164         open my $src, '<', $file or die "$file open for reading failed: $!";
 165         my $dst = lock_file($file);
 166
 167         while (<$src>) {
 168                 my $result = $fn->($_);
 169                 push(@results, $result) if $result;
 170         }
 171
 172         close $dst or die "$file(l) close failed: $!";
 173         close $src;
 174
 175         unlock_file($file, 1);
 176         return @results;
 177 }
 178
 179 sub filedb_grep {
 180         my ($file, $fn) = @_;
 181         my @results = ();
 182
 183         open my $src, '<', $file or die "$file open for reading failed: $!";
 184
 185         while (<$src>) {
 186                 my $result = $fn->($_);
 187                 push(@results, $result) if $result;
 188         }
 189
 190         close $src;
 191
 192         return @results;
 193 }
 194
 195 sub valid_email {
 196         my $email = shift;
 197         defined($email) or $email = '';
 198         return $email =~ /^[a-zA-Z0-9+._-]+@[a-zA-Z0-9.-]+$/;
 199 }
 200
 201 sub clean_email_multi {
 202         my $input = shift;
 203         defined($input) or $input = '';
 204         $input =~ s/^\s+//; $input =~ s/\s+$//;
 205         my %seen = ();
 206         my @newlist = ();
 207         foreach (split(/\s*,\s*/, $input)) {
 208                 next if $_ eq "";
 209                 $seen{lc($_)} = 1, push(@newlist, $_) unless $seen{lc($_)};
 210         }
 211         return join(",", @newlist);
 212 }
 213
 214 sub valid_email_multi {
 215         # each email address must be a valid_email but we silently
 216         # ignore extra spaces at the beginning/end and around any comma(s)
 217         foreach (split(/,/, clean_email_multi(shift))) {
 218                 return 0 unless valid_email($_);
 219         }
 220         return 1;
 221 }
 222
 223 sub valid_web_url {
 224         my $url = shift;
 225         defined($url) or $url = '';
 226         return $url =~
 227                 /^https?:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~:?&=;-]*)?(#[a-zA-Z0-9._-]+)?$/;
 228 }
 229
 230 sub valid_repo_url {
 231         my $url = shift || '';
 232         # Currently neither username nor password is allowed in the URL (except for svn)
 233         # and IPv6 literal addresses are not accepted either.
 234         $Girocco::Config::mirror_svn &&
 235                 $url =~ /^svn(\+https?)?:\/\/([^\@\/\s]+\@)?[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/+~-]*)?$/os
 236                 and return 1;
 237         $Girocco::Config::mirror_darcs &&
 238                 $url =~ /^darcs(?:\+https?)?:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/+~-]*)?$/os
 239                 and return 1;
 240         $Girocco::Config::mirror_bzr &&
 241                 $url =~ /^bzr:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/+~-]*)?$/os
 242                 and return 1;
 243         $Girocco::Config::mirror_hg &&
 244                 $url =~ /^hg\+https?:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/+~-]*)?$/os
 245                 and return 1;
 246         return $url =~  /^(https?|git):\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/+~-]*)?$/;
 247 }
 248
 249 sub extract_url_hostname {
 250         my $url = shift || '';
 251         if ($url =~ m,^bzr://,) {
 252                 $url =~ s,^bzr://,,;
 253                 return 'launchpad.net' if $url =~ /^lp:/;
 254         }
 255         return undef unless $url =~ m,^[A-Za-z0-9+.-]+://[^/],;
 256         $url =~ s,^[A-Za-z0-9+.-]+://,,;
 257         $url =~ s,^([^/]+).*$,$1,;
 258         $url =~ s/:[0-9]*$//;
 259         $url =~ s/^[^\@]*[\@]//;
 260         return $url ? $url : undef;
 261 }
 262
 263 # See these RFCs:
 264 #   RFC 1034 section 3.5
 265 #   RFC 1123 section 2.1
 266 #   RFC 1738 section 3.1
 267 #   RFC 2606 sections 2 & 3
 268 #   RFC 3986 section 3.2.2
 269 sub is_dns_hostname {
 270         my $host = shift;
 271         defined($host) or $host = '';
 272         return 0 if $host eq '' || $host =~ /\s/;
 273         # first remove a trailing '.'
 274         $host =~ s/\.$//;
 275         return 0 if length($host) > 255;
 276         my $octet = '(?:\d|[1-9]\d|1\d{2}|2[0-4]\d|25[0-5])';
 277         return 0 if $host =~ /^$octet\.$octet\.$octet\.$octet$/o;
 278         my @labels = split(/[.]/, $host, -1);
 279         return 0 unless @labels && @labels >= $Girocco::Config::min_dns_labels;
 280         # now check each label
 281         foreach my $label (@labels) {
 282                 return 0 unless length($label) > 0 && length($label) <= 63;
 283                 return 0 unless $label =~ /^[A-Za-z0-9](?:[A-Za-z0-9-]*[A-Za-z0-9])?$/;
 284         }
 285         # disallow RFC 2606 names provided at least two labels are present
 286         if (@labels >= 2) {
 287                 my $tld = lc($labels[-1]);
 288                 return 0 if
 289                     $tld eq 'test' ||
 290                     $tld eq 'example' ||
 291                     $tld eq 'invalid' ||
 292                     $tld eq 'localhost';
 293                 my $sld = lc($labels[-2]);
 294                 return 0 if $sld eq 'example' &&
 295                     ($tld eq 'com' || $tld eq 'net' || $tld eq 'org');
 296         }
 297         return 1;
 298 }
 299
 300 sub is_our_hostname {
 301         my $test = shift || '';
 302         $test =~ s/\.$//;
 303         my %names = ();
 304         my @urls = (
 305                 $Girocco::Config::gitweburl,
 306                 $Girocco::Config::gitwebfiles,
 307                 $Girocco::Config::webadmurl,
 308                 $Girocco::Config::bundlesurl,
 309                 $Girocco::Config::htmlurl,
 310                 $Girocco::Config::httppullurl,
 311                 $Girocco::Config::httpbundleurl,
 312                 $Girocco::Config::httpspushurl,
 313                 $Girocco::Config::gitpullurl,
 314                 $Girocco::Config::pushurl
 315         );
 316         foreach my $url (@urls) {
 317                 if ($url) {
 318                         my $host = extract_url_hostname($url);
 319                         if (defined($host)) {
 320                                 $host =~ s/\.$//;
 321                                 $names{lc($host)} = 1;
 322                         }
 323                 }
 324         }
 325         return $names{lc($test)} ? 1 : 0;
 326 }
 327
 328 my (%_oktags, %_badtags, %_canontags, $_canontagscreated, @_whitetags);
 329 BEGIN {
 330         # These are always okay (a "whitelist") even if they would
 331         # otherwise not be allowed
 332         @_whitetags = (qw(
 333                 .net 2d 3d 6502 68000 68008 68010 68020 68030 68040 68060
 334                 8086 80286 80386 80486 80586 c cc make www x
 335         ));
 336         map({$_oktags{lc($_)}=1} @_whitetags, @Girocco::Config::allowed_tags);
 337         # entries MUST be all lowercase to be effective
 338         %_badtags = (
 339         # These are "nonsense" or pointless tags
 340         about=>1, after=>1, all=>1, also=>1, an=>1, and=>1, another=>1, any=>1,
 341         are=>1, as=>1, at=>1, be=>1, because=>1, been=>1, before=>1, being=>1,
 342         between=>1, both=>1, but=>1, by=>1, came=>1, can=>1, come=>1, could=>1,
 343         did=>1, do=>1, each=>1, for=>1, from=>1, get=>1, got=>1, had=>1, has=>1,
 344         have=>1, he=>1, her=>1, here=>1, him=>1, himself=>1, his=>1, how=>1,
 345         if=>1, in=>1, into=>1, is=>1, it=>1, like=>1, make=>1, many=>1, me=>1,
 346         might=>1, more=>1, most=>1, much=>1, must=>1, my=>1, never=>1, now=>1,
 347         of=>1, oh=>1, on=>1, only=>1, or=>1, other=>1, our=>1, out=>1, over=>1,
 348         said=>1, same=>1, see=>1, should=>1, since=>1, some=>1, still=>1,
 349         such=>1, take=>1, than=>1, that=>1, the=>1, their=>1, them=>1, then=>1,
 350         there=>1, these=>1, they=>1, this=>1, those=>1, through=>1, to=>1,
 351         too=>1, under=>1, up=>1, very=>1, was=>1, way=>1, we=>1, well=>1,
 352         were=>1, what=>1, where=>1, which=>1, while=>1, who=>1, with=>1,
 353         would=>1, yea=>1, yeah=>1, you=>1, your=>1, yup=>1
 354         );
 355         # These are "offensive" tags with at least one letter escaped to
 356         # avoid having this file trigger various safe-scan robots
 357         $_badtags{"a\x73\x73"} = 1;
 358         $_badtags{"a\x73\x73hole"} = 1;
 359         $_badtags{"b\x30\x30b"} = 1;
 360         $_badtags{"b\x30\x30bs"} = 1;
 361         $_badtags{"b\x6f\x6fb"} = 1;
 362         $_badtags{"b\x6f\x6fbs"} = 1;
 363         $_badtags{"b\x75tt"} = 1;
 364         $_badtags{"b\x75ttd\x69\x63k"} = 1;
 365         $_badtags{"c\x6f\x63k"} = 1;
 366         $_badtags{"c\x75\x6e\x74"} = 1;
 367         $_badtags{"d\x69\x63k"} = 1;
 368         $_badtags{"d\x69\x63kb\x75tt"} = 1;
 369         $_badtags{"f\x75\x63k"} = 1;
 370         $_badtags{"in\x63\x65st"} = 1;
 371         $_badtags{"ph\x75\x63k"} = 1;
 372         $_badtags{"p\x6f\x72n"} = 1;
 373         $_badtags{"p\x6f\x72no"} = 1;
 374         $_badtags{"p\x6f\x72nographic"} = 1;
 375         $_badtags{"p\x72\x30n"} = 1;
 376         $_badtags{"p\x72\x6fn"} = 1;
 377         $_badtags{"r\x61\x70e"} = 1;
 378         $_badtags{"s\x65\x78"} = 1;
 379         map({$_badtags{lc($_)}=1} @Girocco::Config::blocked_tags);
 380 }
 381
 382 # A valid tag must only have [a-zA-Z0-9:.+#_-] characters, must start with a
 383 # letter, must not be a noise word, must be more than one character long,
 384 # must not be a repeated letter and must be no more than 32 characters long.
 385 # However, anything in %_oktags is explicitly allowed even if it otherwise
 386 # would violate the rules (except that none of [,\s\\\/] are allowed in tags).
 387 # Returns the canonical name for the tag if the tag is valid otherwise undef.
 388 # Tags consisting of only underscore characters are never valid unless in %_oktags.
 389 sub valid_tag {
 390         local $_ = $_[0];
 391         return undef unless defined($_) && $_ ne "" && !/[,\s\/\\]/;
 392         my $fold = $Girocco::Config::foldtags;
 393         if ($fold && !$_canontagscreated) {
 394                 local $_;
 395                 %_canontags = ();
 396                 $_canontags{lc($_)} = $_ foreach sort({$b cmp $a} @_whitetags, @Girocco::Config::allowed_tags);
 397                 $_canontagscreated = 1;
 398         }
 399         return $_canontags{lc($_)} if $fold && exists($_canontags{lc($_)});
 400         return ($fold ? lc($_) : $_) if $_oktags{lc($_)};
 401         return undef unless /^[a-zA-Z][a-zA-Z0-9:.+#_-]+$/;
 402         my $cu = $_;
 403         $cu =~ tr/:.+#_-//d;
 404         return undef if $cu eq "" || $_badtags{lc($_)} || $_badtags{lc($cu)};
 405         return undef if /^(.)\1+$/ || $cu =~ /^(.)\1+$/;
 406         return length($_) <= 32 ? ($fold ? lc($_) : $_) : undef;
 407 }
 408
 409 # If the passed in argument looks like a URL, return only the stuff up through
 410 # the host:port part otherwise return the entire argument.
 411 sub url_base {
 412         my $url = shift || '';
 413         # See RFC 3968
 414         $url = $1.$2.$3.$4 if $url =~ m,^( [A-Za-z][A-Za-z0-9+.-]*: ) # scheme
 415                 ( // )          # // separator
 416                 ((?:[^\@]+\@)?) # optional userinfo
 417                 ( [^/?#]+ )     # host and port
 418                 (?:[/?#].*)?$,x; # path and optional query string and/or anchor
 419         return $url;
 420 }
 421
 422 # If the passed in argument looks like a URL, return only the stuff following
 423 # the host:port part otherwise return the entire argument.
 424 # If the optional second argument is true, the returned value will have '/'
 425 # appended if it does not already end in '/'.
 426 sub url_path {
 427         my $url = shift || '';
 428         my $add_slash = shift || 0;
 429         # See RFC 3968
 430         $url = $1 if $url =~ m,^(?: [A-Za-z][A-Za-z0-9+.-]*: ) # scheme
 431                 (?: // )        # // separator
 432                 (?: [^\@]+\@ )? # optional userinfo
 433                 (?: [^/?#]+ )   # host and port
 434                 ((?:[/?#].*)?)$,x; # path and optional query string and/or anchor
 435         $url .= '/' if $add_slash && $url !~ m|/$|;
 436         return $url;
 437 }
 438
 439 # If both SERVER_NAME and SERVER_PORT are set pass the argument through url_path
 440 # and then prefix it with the appropriate scheme (HTTPS=?on), host and port and
 441 # return it.  If a something that doesn't look like it could be the start of a
 442 # URL path comes back from url_path or SERVER_NAME is a link-local IPv6 address
 443 # then just return the argument unchanged.
 444 sub url_server {
 445         my $url = shift || '';
 446         my $path = url_path($url);
 447         return $url unless $path eq '' || $path =~ m|^[/?#]|;
 448         return $url unless $ENV{'SERVER_NAME'} && $ENV{'SERVER_PORT'} &&
 449                 $ENV{'SERVER_PORT'} =~ /^[1-9][0-9]{0,4}$/;
 450         return $url if $ENV{'SERVER_NAME'} =~ /^[[]?fe80:/i;
 451         my $server = $ENV{'SERVER_NAME'};
 452         # Deal with Apache bug where IPv6 literal server names do not include
 453         # the required surrounding '[' and ']' characters
 454         $server = '[' . $server . ']' if $server =~ /:/ && $server !~ /^[[]/;
 455         my $ishttps = $ENV{'HTTPS'} && $ENV{'HTTPS'} =~ /^on$/i;
 456         my $portnum = 0 + $ENV{'SERVER_PORT'};
 457         my $port = '';
 458         if (($ishttps && $portnum != 443) || (!$ishttps && $portnum != 80)) {
 459                 $port = ':' . $portnum;
 460         }
 461         return 'http' . ($ishttps ? 's' : '') . '://' . $server . $port . $path;
 462 }
 463
 464 # Returns the number rounded to the nearest tenths.  The ".d" part will be
 465 # excluded if it's ".0" unless the optional second argument is true
 466 sub _tenths {
 467         my $v = shift;
 468         my $use0 = shift;
 469         $v *= 10;
 470         $v += 0.5;
 471         $v = int($v);
 472         return '' . int($v/10) unless $v % 10 || $use0;
 473         return '' . int($v/10) . '.' . ($v%10);
 474 }
 475
 476 # Returns a human-readable size string (e.g. '1.5 MiB') for the value
 477 # (in bytes) passed in.  Returns '0' for undefined or 0 or not all digits.
 478 # Otherwise returns '1 KiB' for < 1024, or else a number rounded to the
 479 # nearest tenths of a KiB, MiB or GiB.
 480 sub human_size {
 481         my $v = shift || 0;
 482         return "0" unless $v && $v =~ /^\d+$/;
 483         return "1 KiB" unless $v > 1024;
 484         $v /= 1024;
 485         return _tenths($v) . " KiB" if $v < 1024;
 486         $v /= 1024;
 487         return _tenths($v) . " MiB" if $v < 1024;
 488         $v /= 1024;
 489         return _tenths($v) . " GiB";
 490 }
 491
 492 # Returns a human duration string (e.g. 1h10m5s for the value (in secs)
 493 # passed in.  Returns the value unchanged if it's not defined or <= 0.
 494 sub human_duration {
 495         my $secs = shift;
 496         return $secs unless defined($secs) && $secs >= 0;
 497         $secs = int($secs);
 498         my $ans = ($secs % 60) . 's';
 499         return $ans if $secs < 60;
 500         $secs = int($secs / 60);
 501         $ans = ($secs % 60) . 'm' . $ans;
 502         return $ans if $secs < 60;
 503         $secs = int($secs / 60);
 504         $ans = ($secs % 24) . 'h' . $ans;
 505         return $ans if $secs < 24;
 506         $secs = int($secs / 24);
 507         return $secs . 'd' . $ans;
 508 }
 509
 510 sub _escapeHTML {
 511         my $str = shift;
 512         $str =~ s/\&/\&amp;/gs;
 513         $str =~ s/\</\&lt;/gs;
 514         $str =~ s/\>/\&gt;/gs;
 515         $str =~ s/\"/\&quot;/gs; #"
 516         return $str;
 517 }
 518
 519 # create relative time string from passed in age in seconds
 520 sub _rel_age {
 521         my $age = shift;
 522         my $age_str;
 523
 524         if ($age > 60*60*24*365*2) {
 525                 $age_str = (int $age/60/60/24/365);
 526                 $age_str .= " years ago";
 527         } elsif ($age > 60*60*24*(365/12)*2) {
 528                 $age_str = int $age/60/60/24/(365/12);
 529                 $age_str .= " months ago";
 530         } elsif ($age > 60*60*24*7*2) {
 531                 $age_str = int $age/60/60/24/7;
 532                 $age_str .= " weeks ago";
 533         } elsif ($age > 60*60*24*2) {
 534                 $age_str = int $age/60/60/24;
 535                 $age_str .= " days ago";
 536         } elsif ($age > 60*60*2) {
 537                 $age_str = int $age/60/60;
 538                 $age_str .= " hours ago";
 539         } elsif ($age > 60*2) {
 540                 $age_str = int $age/60;
 541                 $age_str .= " mins ago";
 542         } elsif ($age > 2) {
 543                 $age_str = int $age;
 544                 $age_str .= " secs ago";
 545         } elsif ($age >= 0) {
 546                 $age_str = "right now";
 547         } else {
 548                 $age_str = "future time";
 549         }
 550         return $age_str;
 551 }
 552
 553 # create relative time string from passed in idle in seconds
 554 sub _rel_idle {
 555         my $idle_str = _rel_age(shift);
 556         $idle_str =~ s/ ago//;
 557         $idle_str = "not at all" if $idle_str eq "right now";
 558         return $idle_str;
 559 }
 560
 561 sub _strftime {
 562         use POSIX qw(strftime);
 563         my ($fmt, $secs, $zonesecs) = @_;
 564         my ($S,$M,$H,$d,$m,$y) = gmtime($secs + $zonesecs);
 565         $zonesecs = int($zonesecs / 60);
 566         $fmt =~ s/%z/\$z/g;
 567         my $ans = strftime($fmt, $S, $M, $H, $d, $m, $y, -1, -1, -1);
 568         my $z;
 569         if ($zonesecs < 0) {
 570                 $z = "-";
 571                 $zonesecs = -$zonesecs;
 572         } else {
 573                 $z = "+";
 574         }
 575         $z .= sprintf("%02d%02d", int($zonesecs/60), $zonesecs % 60);
 576         $ans =~ s/\$z/$z/g;
 577         return $ans;
 578 }
 579
 580 # Take a list of project names and produce a nicely formated table that
 581 # includes owner links and descriptions.  If the list is empty returns ''.
 582 # The first argument may be a hash ref that contains options.  The following
 583 # options are available:
 584 #   target  -- sets the target value of the owner link
 585 #   emptyok -- if true returns an empty table rather than ''
 586 #   sizecol -- if true include a human-readable size column
 587 #   typecol -- if true include type column with hover info
 588 #   changed -- if true include a changed and idle column
 589 sub projects_html_list {
 590         my $options = {};
 591         if (defined($_[0]) && ref($_[0]) eq 'HASH') {
 592                 $options = shift;
 593         }
 594         return '' unless @_ || (defined($options->{emptyok}) && $options->{emptyok});
 595         require Girocco::Project;
 596         my $count = 0;
 597         my $target = '';
 598         $target = " target=\""._escapeHTML($options->{target})."\""
 599                 if defined($options->{target});
 600         my $withsize = defined($options->{sizecol}) && $options->{sizecol};
 601         my $withtype = defined($options->{typecol}) && $options->{typecol};
 602         my $withchanged = defined($options->{changed}) && $options->{changed};
 603         my $sizehead = '';
 604         $sizehead = substr(<<EOT, 0, -1) if $withsize;
 605 <th class="sizecol"><span class="hover">Size<span><span class="head" _data="Size"></span
 606 /><span class="none" /><br />(</span>Fork size excludes objects borrowed from the parent.<span class="none">)</span></span></span></th
 607 >
 608 EOT
 609         my $typehead = '';
 610         $typehead = '<th>Type</th>' if $withtype;
 611         my $chghead = '';
 612         $chghead = substr(<<EOT, 0, -1) if $withchanged;
 613 <th><span class="hover">Changed<span><span class="head" _data="Changed"></span
 614 /><span class="none" /><br />(</span>The last time a ref change was received by this site.<span class="none">)</span></span></span></th
 615 ><th><span class="hover">Idle<span><span class="head" _data="Idle"></span
 616 /><span class="none" /><br />(</span>The most recent committer time in <i>refs/heads</i>.<span class="none">)</span></span></span></th
 617 >
 618 EOT
 619         my $html = <<EOT;
 620 <table class='projectlist'><tr valign="top" align="left"><th>Project</th>$sizehead$typehead$chghead<th class="desc">Description</th></tr>
 621 EOT
 622         my $trclass = ' class="odd"';
 623         foreach (sort({lc($a) cmp lc($b)} @_)) {
 624                 if (Girocco::Project::does_exist($_, 1)) {
 625                         my $proj = Girocco::Project->load($_);
 626                         my $projname = $proj->{name}.".git";
 627                         my $projdesc = $proj->{desc}||'';
 628                         utf8::decode($projdesc) if utf8::valid($projdesc);
 629                         my $sizecol = '';
 630                         if ($withsize) {
 631                                 my $psize = $proj->{reposizek};
 632                                 $psize = undef unless defined($psize) && $psize =~ /^\d+$/;
 633                                 $psize = 0 if !defined($psize) && $proj->is_empty;
 634                                 if (!defined($psize)) {
 635                                         $psize = 'unknown';
 636                                 } elsif (!$psize) {
 637                                         $psize = 'empty';
 638                                 } else {
 639                                         $psize = human_size($psize * 1024);
 640                                         $psize =~ s/ /\&#160;/g;
 641                                 }
 642                                 $sizecol = '<td class="sizecol">'.$psize.'</td>';
 643                         }
 644                         my $typecol = '';
 645                         if ($withtype) {
 646                                 if ($proj->{mirror}) {
 647                                         my $url = _escapeHTML($proj->{url});
 648                                         $typecol = substr(<<EOT, 0, -1);
 649 <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>
 650 EOT
 651                                 } else {
 652                                         my $users = @{$proj->{users}};
 653                                         $users .= ' user';
 654                                         $users .= 's' unless @{$proj->{users}} == 1;
 655                                         my $userlist = join(', ', sort({lc($a) cmp lc($b)} @{$proj->{users}}));
 656                                         my $spncls = length($userlist) > 25 ? '' : ' class="nowrap"';
 657                                         $typecol = $userlist ? substr(<<EOT, 0, -1) : substr(<<EOT, 0, -1);
 658 <td class="type"><span class="hover">$users<span$spncls><br class="none" />$userlist</span></span></td>
 659 EOT
 660 <td class="type">$users</td>
 661 EOT
 662                                 }
 663                         }
 664                         my $changecol = '';
 665                         if ($withchanged) {
 666                                 my $rel = '';
 667                                 my $changetime = $proj->{lastchange};
 668                                 if ($changetime) {
 669                                         my ($ts, $tz);
 670                                         $ts = parse_rfc2822_date($changetime, \$tz);
 671                                         my $ct = _strftime("%Y-%m-%d %T %z", $ts, $tz);
 672                                         $rel = "<span class=\"hover\">" .
 673                                                 _rel_age(time - $ts) .
 674                                                 "<span class=\"nowrap\"><span class=\"before\" _data=\"$changetime\"></span><span class=\"none\"><br />$ct</span></span></span>";
 675                                 } else {
 676                                         $rel = "no commits";
 677                                 }
 678                                 $changecol = substr(<<EOT, 0, -1);
 679 <td class="change">$rel</td>
 680 EOT
 681                                 my $idletime = $proj->{lastactivity};
 682                                 my ($idlesecs, $tz);
 683                                 $idlesecs = parse_any_date($idletime, \$tz) if $idletime;
 684                                 if ($idlesecs) {
 685                                         my $idle2822 = _strftime("%a, %d %b %Y %T %z", $idlesecs, $tz);
 686                                         my $ct = _strftime("%Y-%m-%d %T %z", $idlesecs, $tz);
 687                                         $rel = "<span class=\"hover\">" .
 688                                                 _rel_idle(time - $idlesecs) .
 689                                                 "<span class=\"nowrap\"><span class=\"before\" _data=\"$idle2822\"></span><span class=\"none\"><br />$ct</span></span></span>";
 690                                 } else {
 691                                         $rel = "no commits";
 692                                 }
 693                                 $changecol .= substr(<<EOT, 0, -1);
 694 <td class="idle">$rel</td>
 695 EOT
 696                         }
 697                         $html .= <<EOT;
 698 <tr valign="top"$trclass><td><a href="@{[url_path($Girocco::Config::gitweburl)]}/$projname"$target
 699 >@{[_escapeHTML($projname)]}</td>$sizecol$typecol$changecol<td>@{[_escapeHTML($projdesc)]}</td></tr>
 700 EOT
 701                         $trclass = $trclass ? '' : ' class="odd"';
 702                         ++$count;
 703                 }
 704         }
 705         $html .= <<EOT;
 706 </table>
 707 EOT
 708         return ($count || (defined($options->{emptyok}) && $options->{emptyok})) ? $html : '';
 709 }
 710
 711 my %_month_names;
 712 BEGIN {
 713         %_month_names = (
 714                 jan => 0, feb => 1, mar => 2, apr => 3, may => 4, jun => 5,
 715                 jul => 6, aug => 7, sep => 8, oct => 9, nov => 10, dec => 11
 716         );
 717 }
 718
 719 # Should be in "date '+%a, %d %b %Y %T %z'" format as saved to lastgc, lastrefresh and lastchange
 720 # The leading "%a, " is optional, returns undef if unrecognized date.  This is also known as
 721 # RFC 2822 date format and git's '%cD', '%aD' and --date=rfc2822 format.
 722 # If the second argument is a SCALAR ref, its value will be set to the TZ offset in seconds
 723 sub parse_rfc2822_date {
 724         my $dstr = shift || '';
 725         my $tzoff = shift || '';
 726         $dstr = $1 if $dstr =~/^[^\s]+,\s*(.*)$/;
 727         return undef unless $dstr =~
 728                 /^\s*(\d{1,2})\s+([A-Za-z]{3})\s+(\d{4})\s+(\d{1,2}):(\d{2}):(\d{2})\s+([+-]\d{4})\s*$/;
 729         my ($d,$b,$Y,$H,$M,$S,$z) = ($1,$2,$3,$4,$5,$6,$7);
 730         my $m = $_month_names{lc($b)};
 731         return undef unless defined($m);
 732         my $seconds = timegm(0+$S, 0+$M, 0+$H, 0+$d, 0+$m, 0+$Y);
 733         my $offset = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
 734         $offset = -$offset if substr($z,0,1) eq '-';
 735         $$tzoff = $offset if ref($tzoff) eq 'SCALAR';
 736         return $seconds - $offset;
 737 }
 738
 739 # Will parse any supported date format.  Actually there are three formats
 740 # currently supported:
 741 #   1. RFC 2822 (uses parse_rfc2822_date)
 742 #   2. RFC 3339 / ISO 8601 (T may be ' ' or '_', 'Z' is optional or may be 'UTC', ':' optional in TZ)
 743 #   3. Same as #2 except no colons or hyphens allowed and hours MUST be 2 digits
 744 #   4. unix seconds since epoch with optional +/- trailing TZ (may not have a ':')
 745 # Returns undef if unsupported date.
 746 # If the second argument is a SCALAR ref, its value will be set to the TZ offset in seconds
 747 sub parse_any_date {
 748         my $dstr = shift || '';
 749         my $tzoff = shift || '';
 750         if ($dstr =~ /^\s*([-+]?\d+)(?:\s+([-+]\d{4}))?\s*$/) {
 751                 # Unix timestamp
 752                 my $ts = 0 + $1;
 753                 my $off = 0;
 754                 if ($2) {
 755                         my $z = $2;
 756                         $off = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
 757                         $off = -$off if substr($z,0,1) eq '-';
 758                 }
 759                 $$tzoff = $off if ref($tzoff) eq 'SCALAR';
 760                 return $ts;
 761         }
 762         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*$/ ||
 763             $dstr =~ /^\s*(\d{4})(\d{2})(\d{2})[Tt _](\d{2})(\d{2})(\d{2})(?:[ _]?([Zz]|[Uu][Tt][Cc]|(?:[-+]\d{2}\d{2})))?\s*$/) {
 764                 my ($Y,$m,$d,$H,$M,$S,$z) = ($1,$2,$3,$4,$5,$6,$7||'');
 765                 my $seconds = timegm(0+$S, 0+$M, 0+$H, 0+$d, $m-1, 0+$Y);
 766                 defined($z) && $z ne '' or $z = 'Z';
 767                 $z = uc($z);
 768                 $z =~ s/://;
 769                 substr($z,1,0) = '0' if length($z) == 4;
 770                 my $off = 0;
 771                 if ($z ne 'Z' && $z ne 'UTC') {
 772                         $off = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
 773                         $off = -$off if substr($z,0,1) eq '-';
 774                 }
 775                 $$tzoff = $off if ref($tzoff) eq 'SCALAR';
 776                 return $seconds - $off;
 777         }
 778         return parse_rfc2822_date($dstr, $tzoff);
 779 }
 780
 781 # Input is a number such as a minute interval
 782 # Return value is a random number between the input and 1.25*input
 783 # This can be used to randomize the update and gc operations a bit to avoid
 784 # having them all end up all clustered together
 785 sub rand_adjust {
 786         my $input = shift || 0;
 787         return $input unless $input;
 788         return $input + int(rand(0.25 * $input));
 789 }
 790
 791 # Open a pipe to a new sendmail process.  The '-i' option is always passed to
 792 # the new process followed by any addtional arguments passed in.  Note that
 793 # the sendmail process is only expected to understand the '-i', '-t' and '-f'
 794 # options.  Using any other options via this function is not guaranteed to work.
 795 # A list of recipients may follow the options.  Combining a list of recipients
 796 # with the '-t' option is not recommended.
 797 sub sendmail_pipe {
 798         return undef unless @_;
 799         die "\$Girocco::Config::sendmail_bin is unset or not executable!\n"
 800                 unless $Girocco::Config::sendmail_bin && -x $Girocco::Config::sendmail_bin;
 801         my $result = open(my $pipe, '|-', $Girocco::Config::sendmail_bin, '-i', @_);
 802         return $result ? $pipe : undef;
 803 }
 804
 805 # Open a pipe that works similarly to a mailer such as /usr/bin/mail in that
 806 # if the first argument is '-s', a subject line will be automatically added
 807 # (using the second argument as the subject).  Any remaining arguments are
 808 # expected to be recipient addresses that will be added to an explicit To:
 809 # line as well as passed on to sendmail_pipe.  In addition an
 810 # "Auto-Submitted: auto-generated" header is always added as well as a suitable
 811 # "From:" header.
 812 sub mailer_pipe {
 813         my $subject = undef;
 814         if (@_ >= 2 && $_[0] eq '-s') {
 815                 shift;
 816                 $subject = shift;
 817         }
 818         my $tolist = join(", ", @_);
 819         unshift(@_, '-f', $Girocco::Config::sender) if $Girocco::Config::sender;
 820         my $pipe = sendmail_pipe(@_);
 821         if ($pipe) {
 822                 print $pipe "From: \"$Girocco::Config::name\" ",
 823                         "($Girocco::Config::title) ",
 824                         "<$Girocco::Config::admin>\n";
 825                 print $pipe "To: $tolist\n";
 826                 print $pipe "Subject: $subject\n" if defined($subject);
 827                 print $pipe "MIME-Version: 1.0\n";
 828                 print $pipe "Content-Type: text/plain; charset=utf-8; format=fixed\n";
 829                 print $pipe "Content-Transfer-Encoding: 8bit\n";
 830                 print $pipe "X-Girocco: $Girocco::Config::gitweburl\n"
 831                         unless $Girocco::Config::suppress_x_girocco;
 832                 print $pipe "Auto-Submitted: auto-generated\n";
 833                 print $pipe "\n";
 834         }
 835         return $pipe;
 836 }
 837
 838 sub _goodval {
 839         my $val = shift;
 840         return undef unless defined($val);
 841         $val =~ s/[\r\n]+$//s;
 842         return undef unless $val =~ /^\d+$/;
 843         $val = 0 + $val;
 844         return undef unless $val >= 1;
 845         return $val;
 846 }
 847
 848 # Returns the number of "online" cpus or undef if undetermined
 849 sub online_cpus {
 850         my @confcpus = $^O eq "linux" ?
 851                 qw(_NPROCESSORS_ONLN NPROCESSORS_ONLN) :
 852                 qw(NPROCESSORS_ONLN _NPROCESSORS_ONLN) ;
 853         my $cpus = _goodval(get_cmd('getconf', $confcpus[0]));
 854         return $1 if defined($cpus) && $cpus =~ /^(\d+)$/;
 855         $cpus = _goodval(get_cmd('getconf', $confcpus[1]));
 856         return $1 if defined($cpus) && $cpus =~ /^(\d+)$/;
 857         if ($^O ne "linux") {
 858                 my @sysctls = qw(hw.ncpu);
 859                 unshift(@sysctls, qw(hw.availcpu)) if $^O eq "darwin";
 860                 foreach my $mib (@sysctls) {
 861                         $cpus = _goodval(get_cmd('sysctl', '-n', $mib));
 862                         return $1 if defined($cpus) && $cpus =~ /^(\d+)$/;
 863                 }
 864         }
 865         return undef;
 866 }
 867
 868 # Returns the system page size in bytes or undef if undetermined
 869 # This should never fail on a POSIX system
 870 sub sys_pagesize {
 871         use POSIX ":unistd_h";
 872         my $pagesize = sysconf(_SC_PAGESIZE);
 873         return undef unless defined($pagesize) && $pagesize =~ /^\d+$/;
 874         $pagesize = 0 + $pagesize;
 875         return undef unless $pagesize >= 256;
 876         return $pagesize;
 877 }
 878
 879 # Returns the amount of available physical memory in bytes
 880 # This may differ from the actual amount of physical memory installed
 881 # Returns undef if this cannot be determined
 882 sub sys_memsize {
 883         my $pagesize = sys_pagesize;
 884         if ($pagesize && $^O eq "linux") {
 885                 my $pages = _goodval(get_cmd('getconf', '_PHYS_PAGES'));
 886                 return $pagesize * $pages if $pages;
 887         }
 888         if ($^O ne "linux") {
 889                 my @sysctls = qw(hw.physmem64);
 890                 unshift(@sysctls, qw(hw.memsize)) if $^O eq "darwin";
 891                 foreach my $mib (@sysctls) {
 892                         my $memsize = _goodval(get_cmd('sysctl', '-n', $mib));
 893                         return $memsize if $memsize;
 894                 }
 895                 my $memsize32 = _goodval(get_cmd('sysctl', '-n', 'hw.physmem'));
 896                 return $memsize32 if $memsize32 && $memsize32 <= 2147483647;
 897                 if ($pagesize) {
 898                         my $pages = _goodval(get_cmd('sysctl', '-n', 'hw.availpages'));
 899                         return $pagesize * $pages if $pages;
 900                 }
 901                 return 2147483647 + 1 if $memsize32;
 902         }
 903         return undef;
 904 }
 905
 906 sub _get_max_conf_suffixed_size {
 907         my $conf = shift;
 908         return undef unless defined $conf && $conf =~ /^(\d+)([kKmMgG]?)$/;
 909         my ($val, $suffix) = (0+$1, lc($2));
 910         $val *= 1024 if $suffix eq 'k';
 911         $val *= 1024 * 1024 if $suffix eq 'm';
 912         $val *= 1024 * 1024 * 1024 if $suffix eq 'g';
 913         return $val;
 914 }
 915
 916 sub _make_suffixed_size {
 917         my $size = shift;
 918         return $size if $size % 1024;
 919         $size /= 1024;
 920         return "${size}k" if $size % 1024;
 921         $size /= 1024;
 922         return "${size}m" if $size % 1024;
 923         $size /= 1024;
 924         return "${size}g";
 925 }
 926
 927 # Return the value to pass to --window-memory= for git repack
 928 # If the system memory or number of CPUs cannot be determined, returns "1g"
 929 # Otherwise returns one third the available memory divided by the number of CPUs
 930 # but never more than 1 gigabyte or max_gc_window_memory_size.
 931 sub calc_windowmemory {
 932         my $cpus = online_cpus;
 933         my $memsize = sys_memsize;
 934         my $max = 1024 * 1024 * 1024;
 935         if ($cpus && $memsize) {
 936                 $max = int($memsize / 3 / $cpus);
 937                 $max = 1024 * 1024 * 1024 if $max >= 1024 * 1024 * 1024;
 938         }
 939         my $maxconf = _get_max_conf_suffixed_size($Girocco::Config::max_gc_window_memory_size);
 940         $max = $maxconf if defined($maxconf) && $maxconf && $max > $maxconf;
 941         return _make_suffixed_size($max);
 942 }
 943
 944 # Return the value to set as core.bigFileThreshold for git repack
 945 # If the system memory cannot be determined, returns "256m"
 946 # Otherwise returns the available memory divided by 16
 947 # but never more than 512 megabytes or max_gc_big_file_threshold_size.
 948 sub calc_bigfilethreshold {
 949         my $memsize = sys_memsize;
 950         my $max = 256 * 1024 * 1024;
 951         if ($memsize) {
 952                 $max = int($memsize / 16);
 953                 $max = 512 * 1024 * 1024 if $max >= 512 * 1024 * 1024;
 954         }
 955         my $maxconf = _get_max_conf_suffixed_size($Girocco::Config::max_gc_big_file_threshold_size);
 956         $max = $maxconf if defined($maxconf) && $maxconf && $max > $maxconf;
 957         return _make_suffixed_size($max);
 958 }
 959
 960 # Return the value to use when deciding whether or not to re-calculate object deltas
 961 # If there are no more than this many objects then deltas will be recomputed in
 962 # order to create more efficient pack files.  The new_delta_threshold value
 963 # is constrained to be at least 1000 * cpu cores and no more than 100000.
 964 # The default is sys_memsize rounded up to the nearest multiple of 256 MB and
 965 # then 5000 per 256 MB or 50000 if we cannot determine memory size but never
 966 # more than 100000 or less than 1000 * cpu cores.
 967 sub calc_redeltathreshold {
 968         my $cpus = online_cpus || 1;
 969         if (defined($Girocco::Config::new_delta_threshold) &&
 970             $Girocco::Config::new_delta_threshold =~ /^\d+/) {
 971                 my $ndt = 0 + $Girocco::Config::new_delta_threshold;
 972                 if ($ndt >= $cpus * 1000) {
 973                         return $ndt <= 100000 ? $ndt : 100000;
 974                 }
 975         }
 976         my $calcval = 50000;
 977         my $memsize = sys_memsize;
 978         if ($memsize) {
 979                 my $quantum = 256 * 1024 * 1024;
 980                 $calcval = 5000 * int(($memsize + ($quantum - 1)) / $quantum);
 981                 $calcval = 1000 * $cpus if $calcval < 1000 * $cpus;
 982                 $calcval = 100000 if $calcval > 100000;
 983         }
 984         return $calcval;
 985 }
 986
 987 # $1 => thing to test
 988 # $2 => optional directory, if given and -e "$2/$1$3", then return false
 989 # $3 => optional, defaults to ''
 990 sub has_reserved_suffix {
 991         no warnings; # avoid silly 'unsuccessful stat on filename with \n' warning
 992         my ($name, $dir, $ext) = @_;
 993         $ext = '' unless defined $ext;
 994         return 0 unless defined $name && $name =~ /\.([^.]+)$/;
 995         return 0 unless exists $Girocco::Config::reserved_suffixes{lc($1)};
 996         return 0 if defined $dir && -e "$dir/$name$ext";
 997         return 1;
 998 }
 999
1000 # mostly undoes effect of `use CGI::Carp qw(fatalsToBrowser);`
1001 # mostly undoes effect of `use CGI::Carp qw(warningsToBrowser);`
1002 sub noFatalsToBrowser {
1003         delete $SIG{__DIE__};
1004         delete $SIG{__WARN__};
1005         undef *CORE::GLOBAL::die;
1006         *CORE::GLOBAL::die = sub {
1007                 no warnings;
1008                 my $ec = (0+$!) || ($? >> 8) || 255;
1009                 $ec != ($ec & 0xff) and $ec = 255;
1010                 $ec |= 128 if !(0+$!) && ($? & 0xff);
1011                 my (undef, $fn, $li) = caller(0);
1012                 my $loc = " at " . $fn . " line " . $li . ".\n";
1013                 my $msg = "";
1014                 $msg = join("", @_) if @_;
1015                 $msg = "Died" if $msg eq "";
1016                 $msg .= $loc unless $msg =~ /\n$/;
1017                 die $msg if $^S;
1018                 printf STDERR "%s", $msg;
1019                 exit($ec);
1020         };
1021         undef *CORE::GLOBAL::warn;
1022         *CORE::GLOBAL::warn = sub {
1023                 no warnings;
1024                 my (undef, $fn, $li) = caller(0);
1025                 my $loc = " at " . $fn . " line " . $li . ".\n";
1026                 my $msg = "";
1027                 $msg = join("", @_) if @_;
1028                 $msg = "Warning: something's wrong" if $msg eq "";
1029                 $msg .= $loc unless $msg =~ /\n$/;
1030                 printf STDERR "%s", $msg;
1031         };
1032 }
1033
1034 # mimics Git's symref reading but only for HEAD
1035 # returns undef on failure otherwise an string that is
1036 # either an all-hex (lowercase) value or starts with "refs/"
1037 sub read_HEAD_ref {
1038         my $headpath = $_[0] . "/HEAD";
1039         if (-l $headpath) {
1040                 my $rl = readlink($headpath);
1041                 return defined($rl) && $rl =~ m,^refs/[^\x00-\x1f \x7f~^:\\*?[]+$, ? $rl : undef;
1042         }
1043         open my $fd, '<', $headpath or return undef;
1044         my $hv;
1045         {
1046                 local $/ = undef;
1047                 $hv = <$fd>;
1048         }
1049         close $fd;
1050         defined($hv) or return undef;
1051         chomp $hv;
1052         $hv =~ m,^ref:\s*(refs/[^\x00-\x1f \x7f~^:\\*?[]+)$, and return $1;
1053         $hv =~ m/^[0-9a-fA-F]{40,}$/ and return lc($hv);
1054         return undef;
1055 }
1056
1057 # same as read_HEAD_ref but returns undef
1058 # unless the result starts with "refs/"
1059 sub read_HEAD_symref {
1060         my $hv = read_HEAD_ref(@_);
1061         return defined($hv) && $hv =~ m,^refs/., ? $hv : undef;
1062 }
1063
1064 # similar to Git's test except that GIT_OBJECT_DIRECTORY is ignored
1065 sub is_git_dir {
1066         my $gd = shift;
1067         defined($gd) && $gd ne "" && -d $gd or return undef;
1068         -d "$gd/objects" && -x "$gd/objects" or return 0;
1069         -d "$gd/refs" && -x "$gd/refs" or return 0;
1070         if (-l "$gd/HEAD") {
1071                 my $rl = readlink("$gd/HEAD");
1072                 defined($rl) && $rl =~ m,^refs/., or return 0;
1073                 -e "$gd/HEAD" or return 1;
1074         }
1075         open my $fd, '<', "$gd/HEAD" or return 0;
1076         my $hv;
1077         {
1078                 local $/;
1079                 $hv = <$fd>;
1080         }
1081         close $fd;
1082         defined $hv or return 0;
1083         chomp $hv;
1084         $hv =~ m,^ref:\s*refs/., and return 1;
1085         return $hv =~ /^[0-9a-f]{40}/;
1086 }
1087
1088 # quick check that only tests for the existence of the file but
1089 # does not attempt to actually open it and read the contents
1090 sub is_readonly {
1091         return -f "$Girocco::Config::chroot/etc/readonly" ? 1 : 0;
1092 }
1093
1094 # return string containing read-only message if in read-only mode
1095 # otherwise return empty string
1096 # if the first argument is true, include a <br /> tag before the second
1097 # but only if there is a second line
1098 sub check_readonly {
1099         my $brtag = $_[0] ? "<br />" : "";
1100         my $msg = "";
1101         if (-f "$Girocco::Config::chroot/etc/readonly") {
1102                 $msg = "$Girocco::Config::name is currently read-only, please try again later.";
1103                 my $romsg = "";
1104                 if (open my $fd, '<', "$Girocco::Config::chroot/etc/readonly") {
1105                         local $/;
1106                         $romsg = <$fd>;
1107                         close $fd;
1108                 }
1109                 $romsg ne "" and $msg = $msg . "$brtag\n" . $romsg;
1110         }
1111         return $msg;
1112 }
1113
1114 # Returns a PATH properly prefixed which guarantees that Git is found and the
1115 # basedir/bin utilities are found as intended.  $ENV{PATH} is LEFT UNCHANGED!
1116 # Caller is responsible for assigning result to $ENV{PATH} or otherwise
1117 # arranging for it to be used.  If $ENV{PATH} already has the proper prefix
1118 # then it's returned as-is (making this function idempotent).
1119 # Will die if it cannot determine a suitable full PATH.
1120 # Result is cached so all calls after the first are practically free.
1121 my $var_git_exec_path;
1122 sub util_path {
1123         defined($Girocco::Config::var_git_exec_path) && $Girocco::Config::var_git_exec_path ne "" and
1124                 $var_git_exec_path = $Girocco::Config::var_git_exec_path;
1125         if (!defined($var_git_exec_path) || $var_git_exec_path eq "") {
1126                 defined($Girocco::Config::basedir) && $Girocco::Config::basedir ne "" &&
1127                 -d $Girocco::Config::basedir && -r _ && -x _ or
1128                         die "invalid \$Girocco::Config::basedir setting: $Girocco::Config::basedir\n";
1129                 my $varsfile = $Girocco::Config::basedir . "/shlib_vars.sh";
1130                 if (-f $varsfile && -r _) {
1131                         my $vars;
1132                         if (open $vars, '<', $varsfile) {
1133                                 # last value for var_git_exec_path wins
1134                                 while (<$vars>) {
1135                                         chomp;
1136                                         substr($_, 0, 19) eq "var_git_exec_path=\"" or next;
1137                                         substr($_, -1, 1) eq "\"" or next;
1138                                         my $xd = substr($_, 19, -1);
1139                                         $var_git_exec_path = $xd if -d $xd && -r _ && -x _;
1140                                 }
1141                                 close $vars;
1142                         }
1143                 }
1144                 if (!defined($var_git_exec_path)) {
1145                         my $xd = get_git("--exec-path");
1146                         $var_git_exec_path = $xd if defined($xd) &&
1147                                 (chomp $xd, $xd) ne "" && -d $xd && -r _ && -x _;
1148                 }
1149                 defined($var_git_exec_path) && $var_git_exec_path ne "" or
1150                         die "could not determine \$(git --exec-path) value\n";
1151                 $var_git_exec_path = $1 if $var_git_exec_path =~ m|^(/.+)$|;
1152         }
1153         my $prefix = "$var_git_exec_path:$Girocco::Config::basedir/bin:";
1154         if (substr($ENV{PATH}, 0, length($prefix)) eq $prefix) {
1155                 return $ENV{PATH};
1156         } else {
1157                 return $prefix . $ENV{PATH};
1158         }
1159 }
1160
1161 # Note that Perl performs a "shellish" test in the Perl_do_exec3 function from doio.c,
1162 # but it has slightly different semantics in that whitespace does not automatically
1163 # make something "shellish".  The semantics used here more closely match Git's
1164 # semantics so that Girocco will provide an interpretation more similar to Git's.
1165 sub is_shellish {
1166         return unless defined(local $_ = shift);
1167         return 1 if m#[][\$&*(){}'";:=\\|?<>~`\#\s]#; # contains metacharacters
1168         return 0; # probably not shellish
1169 }
1170
1171 # Works just like the shlib.sh function git_add_config
1172 # except it takes two arguments, first the variable name, second the value
1173 # For example: git_add_config("gc.auto", "0")
1174 # No extra quoting is performed!
1175 # If the name or value requires special quoting, it must be provided by the caller!
1176 # Note this function will only be effective when running Git 1.7.3 or later
1177 sub git_add_config {
1178         my ($name, $val) = @_;
1179         defined($name) && defined($val) or return;
1180         $name ne "" or return;
1181         my $gcp = $ENV{GIT_CONFIG_PARAMETERS};
1182         defined($gcp) or $gcp = '';
1183         $gcp eq "" or $gcp = $gcp . " ";
1184         $gcp .= "'" . $name . '=' . $val . "'";
1185         $ENV{GIT_CONFIG_PARAMETERS} = $gcp;
1186 }
1187
1188 {
1189         package Girocco::Util::JSON::Boolean;
1190         use overload '""' => \&strval;
1191         sub new {
1192                 my $class = shift || __PACKAGE__;
1193                 my $val = shift;
1194                 return bless \$val, $class;
1195         }
1196         sub strval {
1197                 return ${$_[0]};
1198         }
1199 }
1200
1201 # returns a reference to a suitable object that will
1202 # encode to "true" or "false" when passed to to_json
1203 # based on the value passed to this function
1204 # For example, `print to_json(json_bool(1))` prints `true`.
1205 sub json_bool {
1206         return Girocco::Util::JSON::Boolean->new($_[0]);
1207 }
1208
1209 # returns a utf8 encoded result that strictly conforms to
1210 # the JSON standard aka RFC 8259.
1211 # first argument is a scalar or a ref to a SCALAR, ARRAY or HASH
1212 # second argument, if true, requests a "pretty" result
1213 sub to_json {
1214         my ($val, $prt) = @_;
1215         $prt = 1 if $prt && !looks_like_number($prt);
1216         $prt = 0 unless $prt;
1217         return _json_value($val, 0+$prt, "");
1218 }
1219
1220 sub _json_value {
1221         my ($val, $prt, $ndt) = @_;
1222         defined($val) or return "null";
1223         $val = $$val if ref($val) eq 'SCALAR';
1224         my $r = ref($val);
1225         $r eq 'HASH' and return _json_hash($val, $prt, $ndt);
1226         $r eq 'ARRAY' and return _json_array($val, $prt, $ndt);
1227         $r eq 'Girocco::Util::JSON::Boolean' and
1228                 return $val ? "true" : "false";
1229         $r ne '' and $val = "".$val;
1230         looks_like_number($val) and return "".(0+$val);
1231         return _json_str("".$val);
1232 }
1233
1234 my %json_esc; BEGIN {%json_esc=(
1235         '\\' => '\\\\',
1236         '"'  => '\"',
1237         "\b" => '\b',
1238         "\t" => '\t',
1239         "\n" => '\n',
1240         "\f" => '\f',
1241         "\r" => '\r'
1242 )}
1243
1244 sub _json_str {
1245         my $val = shift;
1246         Encode::is_utf8($val) and utf8::encode($val);
1247         $val =~ s/([\\\042\b\t\n\f\r])/$json_esc{$1}/go;
1248         $val =~ s/([\x00-\x1f])/sprintf("\\u%04X",ord($1))/goe;
1249         return '"'.$val.'"';
1250 }
1251
1252 sub _json_array {
1253         my ($val, $prt, $ndt) = @_;
1254         return '[]' unless @{$val};
1255         my $ans = "[";
1256         $ans .= "\n" if $prt;
1257         my $odt = $ndt;
1258         $ndt .= "  ";
1259         for (my $i = 0; $i <= $#{$val}; ++$i) {
1260                 $ans .= $ndt if $prt;
1261                 $ans .= _json_value(${$val}[$i], $prt, $ndt);
1262                 $ans .= "," if $i < $#{$val};
1263                 $ans .= "\n" if $prt;
1264         }
1265         $ndt = $odt;
1266         $ans .= $ndt if $prt;
1267         $ans .= "]";
1268         return $ans;
1269 }
1270
1271 sub _json_hash {
1272         my ($val, $prt, $ndt) = @_;
1273         return '{}' unless %{$val};
1274         my $ans = "{";
1275         $ans .= "\n" if $prt;
1276         my $odt = $ndt;
1277         $ndt .= "  ";
1278         my @keys = sort(keys(%{$val}));
1279         for (my $i = 0; $i <= $#keys; ++$i) {
1280                 $ans .= $ndt if $prt;
1281                 $ans .= _json_str("".$keys[$i]).":";
1282                 $ans .= " " if $prt;
1283                 $ans .= _json_value(${$val}{$keys[$i]}, $prt, $ndt);
1284                 $ans .= "," if $i < $#keys;
1285                 $ans .= "\n" if $prt;
1286         }
1287         $ndt = $odt;
1288         $ans .= $ndt if $prt;
1289         $ans .= "}";
1290         return $ans;
1291 }
1292
1293 # returns undef on error and sets $@ (otherwise $@ cleared)
1294 # if the JSON string to decode is "null" then undef is returned and $@ eq ""
1295 # $_[0] -> string value to decode from JSON
1296 # $_[1] -> if true return integers instead of json_bool for true/false
1297 # $_[2] -> if true strings are utf8::encode'd (i.e. they're bytes not chars)
1298 # returns scalar which will be an ARRAY or HASH ref for JSON array or hash values
1299 # using to_json(from_json($json_value)) will somewhat "normalize" $json_value
1300 # (and optionally pretty it up) and always recombine valid surrogate pairs
1301 sub from_json {
1302         my $ans = undef;
1303         eval {$ans = _from_jsonx(@_)};
1304         return $ans;
1305 }
1306
1307 # will die on bad input
1308 sub _from_jsonx {
1309         my ($val, $nobool, $enc) = @_;
1310         defined($val) or return undef;
1311         my $l = length($val);
1312         pos($val) = 0;
1313         my $atom = _from_json_value(\$val, $l, $nobool, $enc);
1314         $val =~ /\G\s+/gc;
1315         pos($val) >= $l or
1316                 die "garbage found at offset ".pos($val);
1317         return $atom;
1318 }
1319
1320 sub _from_json_value {
1321         my ($val, $l, $nobool, $enc) = @_;
1322         $$val =~ /\G\s+/gc;
1323         my $c = substr($$val, pos($$val), 1);
1324         $c eq "" and die "unexpected end of input at offset ".pos($$val);
1325         $c eq "{" and return _from_json_hash($val, $l, $nobool, $enc);
1326         $c eq "[" and return _from_json_array($val, $l, $nobool, $enc);
1327         $c eq '"' and return _from_json_str($val, $enc);
1328         index("-0123456789", $c) >= 0 and do {
1329                 $$val =~ /\G(-?(?:0|[1-9]\d*)(?:\.\d+)?(?:[eE][-+]?\d+)?)/gc and
1330                         return int($1) == $1 ? int($1) : $1;
1331                 die "invalid JSON number at offset ".pos($$val);
1332         };
1333         $$val =~ /\Gnull\b/gc and return undef;
1334         $$val =~ /\Gtrue\b/gc and return $nobool?1:json_bool(1);
1335         $$val =~ /\Gfalse\b/gc and return $nobool?0:json_bool(0);
1336         die "invalid JSON value at offset ".pos($$val);
1337 }
1338
1339 my %json_unesc; BEGIN {%json_unesc=(
1340         '\\' => "\\",
1341         '"'  => '"',
1342         'b'  => "\b",
1343         't'  => "\t",
1344         'n'  => "\n",
1345         'f'  => "\f",
1346         'r'  => "\r"
1347 )}
1348
1349 sub _from_json_str {
1350         my ($val, $enc) = @_;
1351         my $opos = pos($$val);
1352         $$val =~ /\G\042((?:[^\\\042]|\\.)*)\042/gsc and
1353                 return _from_json_strval($1, $opos+1, $enc);
1354         die "invalid JSON string starting at offset $opos";
1355 }
1356
1357 sub _from_json_strval {
1358         my ($val, $pos, $enc) = @_;
1359         Encode::is_utf8($val) || utf8::decode($val) or
1360                 die "invalid UTF-8 string starting at offset $pos";
1361         $val =~ s{\\([\\\042btnfr]|u[0-9a-fA-F]{4})}{
1362                 substr($1,0,1) eq "u" ? &{sub{
1363                         my $c = hex(substr($1,1,4));
1364                         0xD800 <= $c && $c <= 0xDFFF ?
1365                                 "\\" . $1 :
1366                                 chr(hex(substr($1,1,4)))
1367                 }} : $json_unesc{$1}
1368         }goxe;
1369         $val =~ s{\\u([Dd][89AaBb][0-9a-fA-F]{2})\\u([Dd][CcDdEeFf][0-9a-fA-F]{2})}{
1370                 chr(( ((hex($1)&0x03FF)<<10) | (hex($2)&0x03FF) ) + 0x10000)
1371         }goxe;
1372         !Encode::is_utf8($val) || utf8::encode($val) if $enc;
1373         return $val;
1374 }
1375
1376 sub _from_json_array {
1377         my ($val, $l, $nobool, $enc) = @_;
1378         my @a = ();
1379         $$val =~ /\G\[/gc or die "expected '[' at offset ".pos($$val);
1380         my $wantcomma = 0;
1381         while (pos($$val) < $l && substr($$val, pos($$val), 1) ne "]") {
1382                 $$val =~ /\G\s+/gc and next;
1383                 !$wantcomma && substr($$val, pos($$val), 1) eq "," and
1384                         die "unexpected comma (,) in JSON array at offset ".pos($$val);
1385                 $wantcomma && !($$val =~ /\G,/gc) and
1386                         die "expected comma (,) or right-bracket (]) in JSON array at offset ".pos($$val);
1387                 push(@a, _from_json_value($val, $l, $nobool, $enc));
1388                 $wantcomma = 1;
1389         }
1390         $$val =~ /\G\]/gc or die "expected ']' at offset ".pos($$val);
1391         return \@a;
1392 }
1393
1394 sub _from_json_hash {
1395         my ($val, $l, $nobool, $enc) = @_;
1396         my %h = ();
1397         $$val =~ /\G\{/gc or die "expected '{' at offset ".pos($$val);
1398         my $wantc = "";
1399         my $k = undef;
1400         while (pos($$val) < $l && substr($$val, pos($$val), 1) ne "}") {
1401                 $$val =~ /\G\s+/gc and next;
1402                 !$wantc && index(":,", substr($$val, pos($$val), 1)) >= 0 and
1403                         die "unexpected colon (:) or comma (,) in JSON hash at offset ".pos($$val);
1404                 $wantc eq ":" && !($$val =~ /\G:/gc) and
1405                         die "expected colon (:) in JSON hash at offset ".pos($$val);
1406                 $wantc eq "," && !($$val =~ /\G,/gc) and
1407                         die "expected comma (,) or right-brace (}) in JSON hash at offset ".pos($$val);
1408                 $wantc and $$val =~ /\G\s+/gc;
1409                 $wantc eq "," and $wantc = "";
1410                 !$wantc && substr($$val, pos($$val), 1) ne '"' and
1411                         die "expected double-quote (\") in JSON hash at offset ".pos($$val);
1412                 !$wantc and do {
1413                         $k = _from_json_str($val, $enc);
1414                         $wantc = ":";
1415                         next;
1416                 };
1417                 $h{$k} = _from_json_value($val, $l, $nobool, $enc);
1418                 $wantc = ",";
1419         }
1420         $wantc ne ":" or die "expected ':' at offset ".pos($$val);
1421         $$val =~ /\G\}/gc or die "expected '}' at offset ".pos($$val);
1422         return \%h;
1423 }
1424
1425 # $_[0] -> full absolute path to a git ".git" directory
1426 # $_[1] -> "old" ref hash value
1427 # $_[2] -> "new" ref hash value
1428 # returns:
1429 #   scalar context: "..." -- if forced ref update detected (i.e. NOT a fast-forward)
1430 #                   ".."  -- any other condition (i.e. fast-forward/creation/deletion/no change/etc.)
1431 #   array context: [0] -> scalar context result
1432 #                  [1] -> true value if a git command had to be run
1433 sub ref_indicator {
1434         return '..' unless defined($_[0]);
1435         my ($git_dir, $old, $new) = @_;
1436         return '..' unless defined($old) && defined($new) && $old !~ /^0+$/ && $new !~ /^0+$/ && $old ne $new;
1437         # In many cases `git merge-base` is slower than this even if using the
1438         # `--is-ancestor` option available since Git 1.8.0, but it's never faster
1439         my $ans = get_git("--git-dir=$git_dir", "rev-list", "-n", "1", "^$new^0", "$old^0", "--") ? '...' : '..';
1440         return wantarray ? ($ans, 1) : $ans;
1441 }
1442
1443 # return the token key to use for the passed in category
1444 # if there is no such token or it cannot be read or is invalid
1445 # then silently return undef
1446 # category names must currently be 32 or fewer alphanumeric
1447 # characters where the first must be an alpha char
1448 # $_[0] -> category name
1449 sub get_token_key {
1450         my $cname = shift;
1451         defined($cname) or return undef;
1452         $cname = lc($cname);
1453         $cname =~ /^([a-z][a-z0-9]{0,31})$/ or return undef;
1454         $cname = $1;
1455         my $tf = $Girocco::Config::certsdir . "/tokenkeys/$cname.tky";
1456         -e $tf && -f _ && -r _ && -s _ or return undef;
1457         my $fh;
1458         open $fh, '<', $tf or return undef;
1459         my $tk = <$fh>;
1460         close $fh;
1461         defined($tk) or return undef;
1462         chomp($tk);
1463         $tk =~ /^([A-Za-z0-9_-]{48})$/ or return undef;
1464         return $1;
1465 }
1466
1467 # just like create_timed_token except that
1468 # the first argument is a category name instead of
1469 # the actual HMAC "secret"
1470 # $_[0] -> category name to pass to get_token_key
1471 # $_[1] -> optional instance info to include in "text"
1472 # $_[2] -> duration of validity in seconds (5..2147483647)
1473 # $_[3] -> optional time stamp (secs since unix Epoch)
1474 #          if not provided, current time is used
1475 # Returns a base64_url token (no trailing '='s) that is
1476 # valid starting at $_[3] and expires $_[2] seconds after $_[3].
1477 # Unless get_token_key fails in which case it returns undef.
1478 #
1479 sub get_timed_token {
1480         my ($catg, $extra, $duration, $start) = @_;
1481         my $tk = get_token_key($catg);
1482         defined($tk) && $tk ne "" or return undef;
1483         return create_timed_token($tk, $extra, $duration, $start);
1484 }
1485
1486 # return a hidden "token" <input /> field if the token ($_[0])
1487 # can be read, otherwise the empty string "".
1488 # $_[0] -> the token category (passed to get_token_key)
1489 # $_[1] -> the optional instance info (passed to create_timed_token)
1490 # $_[2] -> the duration of validity (passed to create_timed_token)
1491 # $_[3] -> optional name of field (defaults to "token")
1492 # returns a "hidden" XHTML input element or the empty string if
1493 # get_timed_token fails.  The token starting time will be the
1494 # current time.
1495 #
1496 sub get_token_field {
1497         my ($catg, $extra, $duration, $name) = @_;
1498         defined($name) && $name ne "" or $name = "token";
1499         my $tt = get_timed_token($catg, $extra, $duration);
1500         defined($tt) && $tt ne "" or return "";
1501         return "<input type=\"hidden\" name=\"$name\" value=\"$tt\" />";
1502 }
1503
1504 # just like verify_timed_token except that
1505 # the second argument is a category name instead of
1506 # the actual HMAC "secret"
1507 # $_[0] -> a create_timed_token/get_timed_token to check
1508 # $_[1] -> category name to pass to get_token_key
1509 # $_[2] -> optional instance info to include in "text"
1510 # $_[3] -> duration of validity in seconds (5..2147483647)
1511 # $_[4] -> optional time stamp (secs since unix Epoch)
1512 #          if not provided, current time is used
1513 # Returns true if $_[4] falls within the token's validity range
1514 # Returns false for a bad or expired token
1515 sub check_timed_token {
1516         my ($token, $catg, $extra, $duration, $start) = @_;
1517         my $tk = get_token_key($catg);
1518         defined($tk) && $tk ne "" or return undef;
1519         return verify_timed_token($token, $tk, $extra, $duration, $start);
1520 }
1521
1522 # similar to the shlib.sh function v_get_proj_from_dir but different details
1523 # attempt to convert the first argument interpreted as a full path name to
1524 # a Girocco project name.  Unlike v_get_proj_from_dir, there's no magic
1525 # "_external/..." name fallback if not found.
1526 # $_[0] -> directory name to translate, relative to getcwd if not absolute
1527 # Returns name of existing Girocco project on success, undef on failure
1528 # Minor quibbles are handled (e.g. trailing '.git' omitted and shouldn't have been)
1529 # If the resolved absolute path ends with "/.git" and that's a "gitdir: " file
1530 # that will be followed too.
1531 # And finally, if we seem to have ended up in a worktree, that will be handled too
1532 sub get_project_from_dir {
1533         use Cwd qw(realpath);
1534         use File::Basename qw(dirname);
1535         require Girocco::Project;
1536         my $path = shift;
1537         defined($path) && $path ne "" or $path = ".";
1538         $path =~ s{/+$}{}; $path ne "" or $path = "/";
1539         my $fallback = sub {
1540                 my $fallback = $path;
1541                 # if a top-level working tree directory was specified
1542                 # take that to mean its associated .git dir otherwise
1543                 # if a sibling directory with a ".git" extension exists
1544                 # such as where forked projects are involved, try that
1545                 if ($path !~ /\/\.git$/ && -e "$fallback/.git") {
1546                         $fallback .= "/.git";
1547                 } else {
1548                         (my $test = $path) =~ s/\.$//;
1549                         if ($test !~ /\.git$/ && -d "$test.git") {
1550                                 # project fork directory trees always
1551                                 # use bare repositories; do NOT check
1552                                 # for a "$test.git/.git" here;
1553                                 # but a 2nd fallback round will!
1554                                 $fallback = "$test.git";
1555                         }
1556                 }
1557                 $fallback ne $path && -e $fallback or return undef;
1558                 return get_project_from_dir($fallback);
1559         };
1560         my $rpath = realpath($path);
1561         defined($rpath) && -e $rpath or return &$fallback;
1562         if ($rpath =~ /\/\.git$/ && -f $rpath && -s _) {
1563                 # grumble
1564                 # see if it's a gitdir: link (allowing relative ones)
1565                 # and pick up its destination
1566                 # no fallbacks in here since an existing ".git"
1567                 # was found and it was a file not a dir
1568                 open my $gdf, '<', $rpath or return undef;
1569                 my $gdline = <$gdf>;
1570                 close $gdf;
1571                 defined($gdline) && $gdline =~ /^gitdir:\s*([^\s].*)$/
1572                         or return undef;
1573                 (my $gitdir = $1) =~ s/\s+$//;
1574                 if (substr($gitdir, 0, 1) ne "/") {
1575                         # it's relative
1576                         $gitdir = dirname($rpath)."/".$gitdir;
1577                 }
1578                 -e $gitdir or return undef;
1579                 $gitdir = realpath($gitdir);
1580                 # a gitdir: link must point to a real directory
1581                 defined($gitdir) && -d $gitdir or return undef;
1582                 $rpath = $gitdir;
1583         }
1584         # an existing directory is required at this point
1585         # if it's an existing not-a-directory, no fallback
1586         -d $rpath or return undef;
1587         if (!is_git_dir($rpath)) {
1588                 # grumble
1589                 # see if it might be a worktree
1590                 if (-f "$rpath/HEAD" && -s _ && -f "$rpath/commondir" && -s _) {
1591                         open my $cdf, '<', "$rpath/commondir" or return &$fallback;
1592                         my $cdl = <$cdf>;
1593                         close $cdf;
1594                         defined($cdl) && $cdl ne "" or return &$fallback;
1595                         $cdl =~ s/^\s+//; $cdl =~ s/\s+$//;
1596                         $cdl ne "" or return &$fallback;
1597                         # for now require "../.." for safety
1598                         $cdl eq "../.." or return &$fallback;
1599                         $rpath = dirname(dirname($rpath));
1600                         is_git_dir($rpath) or return &$fallback;
1601                 } else {
1602                         return &$fallback; # yes, try a ".git" suffix fallback
1603                 }
1604         }
1605         # at this point $rpath is a "realpath" to an existing directory
1606         # that appears to be a non-worktree $GIT_DIR -- no more fallbacks
1607         # try the quick check first
1608         my $rrr = realpath($Girocco::Config::reporoot);
1609         defined($rrr) && $rrr ne "" or return undef;
1610         if ($rpath =~ m{^\Q$rrr\E/(.+)$}) {
1611                 (my $proj = $1) =~ s/\.git$//;
1612                 return $proj ne "" && Girocco::Project::does_exist($proj, 1)
1613                         ? $proj : undef;
1614         }
1615         # finally, attempt to look up the path in gitdir.list if all else fails
1616         my $gdlp = "$Girocco::Config::projlist_cache_dir/gitdir.list";
1617         -f $gdlp && -s _ or return undef;
1618         my $projname = undef;
1619         open my $gdlf, '<', $gdlp or return undef;
1620         while (<$gdlf>) {
1621                 /^([^\s]+)\s+([^\s].*)$/ or next;
1622                 $2 eq $rpath or next;
1623                 $projname = $1;
1624                 last;
1625         }
1626         close $gdlf;
1627         defined($projname) && $projname ne "" && Girocco::Project::does_exist($projname, 1)
1628                 or $projname = undef;
1629         return $projname;
1630 }
1631
1632 1;