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);
  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 sub valid_tag {
 389         local $_ = $_[0];
 390         return undef unless defined($_) && $_ ne "" && !/[,\s\/\\]/;
 391         my $fold = $Girocco::Config::foldtags;
 392         if ($fold && !$_canontagscreated) {
 393                 local $_;
 394                 %_canontags = ();
 395                 $_canontags{lc($_)} = $_ foreach sort({$b cmp $a} @_whitetags, @Girocco::Config::allowed_tags);
 396                 $_canontagscreated = 1;
 397         }
 398         return $_canontags{lc($_)} if $fold && exists($_canontags{lc($_)});
 399         return ($fold ? lc($_) : $_) if $_oktags{lc($_)};
 400         return undef unless /^[a-zA-Z][a-zA-Z0-9:.+#_-]+$/;
 401         return undef if $_badtags{lc($_)};
 402         return undef if /^(.)\1+$/;
 403         return length($_) <= 32 ? ($fold ? lc($_) : $_) : undef;
 404 }
 405
 406 # If the passed in argument looks like a URL, return only the stuff up through
 407 # the host:port part otherwise return the entire argument.
 408 sub url_base {
 409         my $url = shift || '';
 410         # See RFC 3968
 411         $url = $1.$2.$3.$4 if $url =~ m,^( [A-Za-z][A-Za-z0-9+.-]*: ) # scheme
 412                 ( // )          # // separator
 413                 ((?:[^\@]+\@)?) # optional userinfo
 414                 ( [^/?#]+ )     # host and port
 415                 (?:[/?#].*)?$,x; # path and optional query string and/or anchor
 416         return $url;
 417 }
 418
 419 # If the passed in argument looks like a URL, return only the stuff following
 420 # the host:port part otherwise return the entire argument.
 421 # If the optional second argument is true, the returned value will have '/'
 422 # appended if it does not already end in '/'.
 423 sub url_path {
 424         my $url = shift || '';
 425         my $add_slash = shift || 0;
 426         # See RFC 3968
 427         $url = $1 if $url =~ m,^(?: [A-Za-z][A-Za-z0-9+.-]*: ) # scheme
 428                 (?: // )        # // separator
 429                 (?: [^\@]+\@ )? # optional userinfo
 430                 (?: [^/?#]+ )   # host and port
 431                 ((?:[/?#].*)?)$,x; # path and optional query string and/or anchor
 432         $url .= '/' if $add_slash && $url !~ m|/$|;
 433         return $url;
 434 }
 435
 436 # If both SERVER_NAME and SERVER_PORT are set pass the argument through url_path
 437 # and then prefix it with the appropriate scheme (HTTPS=?on), host and port and
 438 # return it.  If a something that doesn't look like it could be the start of a
 439 # URL path comes back from url_path or SERVER_NAME is a link-local IPv6 address
 440 # then just return the argument unchanged.
 441 sub url_server {
 442         my $url = shift || '';
 443         my $path = url_path($url);
 444         return $url unless $path eq '' || $path =~ m|^[/?#]|;
 445         return $url unless $ENV{'SERVER_NAME'} && $ENV{'SERVER_PORT'} &&
 446                 $ENV{'SERVER_PORT'} =~ /^[1-9][0-9]{0,4}$/;
 447         return $url if $ENV{'SERVER_NAME'} =~ /^[[]?fe80:/i;
 448         my $server = $ENV{'SERVER_NAME'};
 449         # Deal with Apache bug where IPv6 literal server names do not include
 450         # the required surrounding '[' and ']' characters
 451         $server = '[' . $server . ']' if $server =~ /:/ && $server !~ /^[[]/;
 452         my $ishttps = $ENV{'HTTPS'} && $ENV{'HTTPS'} =~ /^on$/i;
 453         my $portnum = 0 + $ENV{'SERVER_PORT'};
 454         my $port = '';
 455         if (($ishttps && $portnum != 443) || (!$ishttps && $portnum != 80)) {
 456                 $port = ':' . $portnum;
 457         }
 458         return 'http' . ($ishttps ? 's' : '') . '://' . $server . $port . $path;
 459 }
 460
 461 # Returns the number rounded to the nearest tenths.  The ".d" part will be
 462 # excluded if it's ".0" unless the optional second argument is true
 463 sub _tenths {
 464         my $v = shift;
 465         my $use0 = shift;
 466         $v *= 10;
 467         $v += 0.5;
 468         $v = int($v);
 469         return '' . int($v/10) unless $v % 10 || $use0;
 470         return '' . int($v/10) . '.' . ($v%10);
 471 }
 472
 473 # Returns a human-readable size string (e.g. '1.5 MiB') for the value
 474 # (in bytes) passed in.  Returns '0' for undefined or 0 or not all digits.
 475 # Otherwise returns '1 KiB' for < 1024, or else a number rounded to the
 476 # nearest tenths of a KiB, MiB or GiB.
 477 sub human_size {
 478         my $v = shift || 0;
 479         return "0" unless $v && $v =~ /^\d+$/;
 480         return "1 KiB" unless $v > 1024;
 481         $v /= 1024;
 482         return _tenths($v) . " KiB" if $v < 1024;
 483         $v /= 1024;
 484         return _tenths($v) . " MiB" if $v < 1024;
 485         $v /= 1024;
 486         return _tenths($v) . " GiB";
 487 }
 488
 489 # Returns a human duration string (e.g. 1h10m5s for the value (in secs)
 490 # passed in.  Returns the value unchanged if it's not defined or <= 0.
 491 sub human_duration {
 492         my $secs = shift;
 493         return $secs unless defined($secs) && $secs >= 0;
 494         $secs = int($secs);
 495         my $ans = ($secs % 60) . 's';
 496         return $ans if $secs < 60;
 497         $secs = int($secs / 60);
 498         $ans = ($secs % 60) . 'm' . $ans;
 499         return $ans if $secs < 60;
 500         $secs = int($secs / 60);
 501         $ans = ($secs % 24) . 'h' . $ans;
 502         return $ans if $secs < 24;
 503         $secs = int($secs / 24);
 504         return $secs . 'd' . $ans;
 505 }
 506
 507 sub _escapeHTML {
 508         my $str = shift;
 509         $str =~ s/\&/\&amp;/gs;
 510         $str =~ s/\</\&lt;/gs;
 511         $str =~ s/\>/\&gt;/gs;
 512         $str =~ s/\"/\&quot;/gs; #"
 513         return $str;
 514 }
 515
 516 # create relative time string from passed in age in seconds
 517 sub _rel_age {
 518         my $age = shift;
 519         my $age_str;
 520
 521         if ($age > 60*60*24*365*2) {
 522                 $age_str = (int $age/60/60/24/365);
 523                 $age_str .= " years ago";
 524         } elsif ($age > 60*60*24*(365/12)*2) {
 525                 $age_str = int $age/60/60/24/(365/12);
 526                 $age_str .= " months ago";
 527         } elsif ($age > 60*60*24*7*2) {
 528                 $age_str = int $age/60/60/24/7;
 529                 $age_str .= " weeks ago";
 530         } elsif ($age > 60*60*24*2) {
 531                 $age_str = int $age/60/60/24;
 532                 $age_str .= " days ago";
 533         } elsif ($age > 60*60*2) {
 534                 $age_str = int $age/60/60;
 535                 $age_str .= " hours ago";
 536         } elsif ($age > 60*2) {
 537                 $age_str = int $age/60;
 538                 $age_str .= " mins ago";
 539         } elsif ($age > 2) {
 540                 $age_str = int $age;
 541                 $age_str .= " secs ago";
 542         } elsif ($age >= 0) {
 543                 $age_str = "right now";
 544         } else {
 545                 $age_str = "future time";
 546         }
 547         return $age_str;
 548 }
 549
 550 # create relative time string from passed in idle in seconds
 551 sub _rel_idle {
 552         my $idle_str = _rel_age(shift);
 553         $idle_str =~ s/ ago//;
 554         $idle_str = "not at all" if $idle_str eq "right now";
 555         return $idle_str;
 556 }
 557
 558 sub _strftime {
 559         use POSIX qw(strftime);
 560         my ($fmt, $secs, $zonesecs) = @_;
 561         my ($S,$M,$H,$d,$m,$y) = gmtime($secs + $zonesecs);
 562         $zonesecs = int($zonesecs / 60);
 563         $fmt =~ s/%z/\$z/g;
 564         my $ans = strftime($fmt, $S, $M, $H, $d, $m, $y, -1, -1, -1);
 565         my $z;
 566         if ($zonesecs < 0) {
 567                 $z = "-";
 568                 $zonesecs = -$zonesecs;
 569         } else {
 570                 $z = "+";
 571         }
 572         $z .= sprintf("%02d%02d", int($zonesecs/60), $zonesecs % 60);
 573         $ans =~ s/\$z/$z/g;
 574         return $ans;
 575 }
 576
 577 # Take a list of project names and produce a nicely formated table that
 578 # includes owner links and descriptions.  If the list is empty returns ''.
 579 # The first argument may be a hash ref that contains options.  The following
 580 # options are available:
 581 #   target  -- sets the target value of the owner link
 582 #   emptyok -- if true returns an empty table rather than ''
 583 #   sizecol -- if true include a human-readable size column
 584 #   typecol -- if true include type column with hover info
 585 #   changed -- if true include a changed and idle column
 586 sub projects_html_list {
 587         my $options = {};
 588         if (defined($_[0]) && ref($_[0]) eq 'HASH') {
 589                 $options = shift;
 590         }
 591         return '' unless @_ || (defined($options->{emptyok}) && $options->{emptyok});
 592         require Girocco::Project;
 593         my $count = 0;
 594         my $target = '';
 595         $target = " target=\""._escapeHTML($options->{target})."\""
 596                 if defined($options->{target});
 597         my $withsize = defined($options->{sizecol}) && $options->{sizecol};
 598         my $withtype = defined($options->{typecol}) && $options->{typecol};
 599         my $withchanged = defined($options->{changed}) && $options->{changed};
 600         my $sizehead = '';
 601         $sizehead = substr(<<EOT, 0, -1) if $withsize;
 602 <th class="sizecol"><span class="hover">Size<span><span class="head" _data="Size"></span
 603 /><span class="none" /><br />(</span>Fork size excludes objects borrowed from the parent.<span class="none">)</span></span></span></th
 604 >
 605 EOT
 606         my $typehead = '';
 607         $typehead = '<th>Type</th>' if $withtype;
 608         my $chghead = '';
 609         $chghead = substr(<<EOT, 0, -1) if $withchanged;
 610 <th><span class="hover">Changed<span><span class="head" _data="Changed"></span
 611 /><span class="none" /><br />(</span>The last time a ref change was received by this site.<span class="none">)</span></span></span></th
 612 ><th><span class="hover">Idle<span><span class="head" _data="Idle"></span
 613 /><span class="none" /><br />(</span>The most recent committer time in <i>refs/heads</i>.<span class="none">)</span></span></span></th
 614 >
 615 EOT
 616         my $html = <<EOT;
 617 <table class='projectlist'><tr valign="top" align="left"><th>Project</th>$sizehead$typehead$chghead<th class="desc">Description</th></tr>
 618 EOT
 619         my $trclass = ' class="odd"';
 620         foreach (sort({lc($a) cmp lc($b)} @_)) {
 621                 if (Girocco::Project::does_exist($_, 1)) {
 622                         my $proj = Girocco::Project->load($_);
 623                         my $projname = $proj->{name}.".git";
 624                         my $projdesc = $proj->{desc}||'';
 625                         utf8::decode($projdesc) if utf8::valid($projdesc);
 626                         my $sizecol = '';
 627                         if ($withsize) {
 628                                 my $psize = $proj->{reposizek};
 629                                 $psize = undef unless defined($psize) && $psize =~ /^\d+$/;
 630                                 $psize = 0 if !defined($psize) && $proj->is_empty;
 631                                 if (!defined($psize)) {
 632                                         $psize = 'unknown';
 633                                 } elsif (!$psize) {
 634                                         $psize = 'empty';
 635                                 } else {
 636                                         $psize = human_size($psize * 1024);
 637                                         $psize =~ s/ /\&#160;/g;
 638                                 }
 639                                 $sizecol = '<td class="sizecol">'.$psize.'</td>';
 640                         }
 641                         my $typecol = '';
 642                         if ($withtype) {
 643                                 if ($proj->{mirror}) {
 644                                         my $url = _escapeHTML($proj->{url});
 645                                         $typecol = substr(<<EOT, 0, -1);
 646 <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>
 647 EOT
 648                                 } else {
 649                                         my $users = @{$proj->{users}};
 650                                         $users .= ' user';
 651                                         $users .= 's' unless @{$proj->{users}} == 1;
 652                                         my $userlist = join(', ', sort({lc($a) cmp lc($b)} @{$proj->{users}}));
 653                                         my $spncls = length($userlist) > 25 ? '' : ' class="nowrap"';
 654                                         $typecol = $userlist ? substr(<<EOT, 0, -1) : substr(<<EOT, 0, -1);
 655 <td class="type"><span class="hover">$users<span$spncls><br class="none" />$userlist</span></span></td>
 656 EOT
 657 <td class="type">$users</td>
 658 EOT
 659                                 }
 660                         }
 661                         my $changecol = '';
 662                         if ($withchanged) {
 663                                 my $rel = '';
 664                                 my $changetime = $proj->{lastchange};
 665                                 if ($changetime) {
 666                                         my ($ts, $tz);
 667                                         $ts = parse_rfc2822_date($changetime, \$tz);
 668                                         my $ct = _strftime("%Y-%m-%d %T %z", $ts, $tz);
 669                                         $rel = "<span class=\"hover\">" .
 670                                                 _rel_age(time - $ts) .
 671                                                 "<span class=\"nowrap\"><span class=\"before\" _data=\"$changetime\"></span><span class=\"none\"><br />$ct</span></span></span>";
 672                                 } else {
 673                                         $rel = "no commits";
 674                                 }
 675                                 $changecol = substr(<<EOT, 0, -1);
 676 <td class="change">$rel</td>
 677 EOT
 678                                 my $idletime = $proj->{lastactivity};
 679                                 my ($idlesecs, $tz);
 680                                 $idlesecs = parse_any_date($idletime, \$tz) if $idletime;
 681                                 if ($idlesecs) {
 682                                         my $idle2822 = _strftime("%a, %d %b %Y %T %z", $idlesecs, $tz);
 683                                         my $ct = _strftime("%Y-%m-%d %T %z", $idlesecs, $tz);
 684                                         $rel = "<span class=\"hover\">" .
 685                                                 _rel_idle(time - $idlesecs) .
 686                                                 "<span class=\"nowrap\"><span class=\"before\" _data=\"$idle2822\"></span><span class=\"none\"><br />$ct</span></span></span>";
 687                                 } else {
 688                                         $rel = "no commits";
 689                                 }
 690                                 $changecol .= substr(<<EOT, 0, -1);
 691 <td class="idle">$rel</td>
 692 EOT
 693                         }
 694                         $html .= <<EOT;
 695 <tr valign="top"$trclass><td><a href="@{[url_path($Girocco::Config::gitweburl)]}/$projname"$target
 696 >@{[_escapeHTML($projname)]}</td>$sizecol$typecol$changecol<td>@{[_escapeHTML($projdesc)]}</td></tr>
 697 EOT
 698                         $trclass = $trclass ? '' : ' class="odd"';
 699                         ++$count;
 700                 }
 701         }
 702         $html .= <<EOT;
 703 </table>
 704 EOT
 705         return ($count || (defined($options->{emptyok}) && $options->{emptyok})) ? $html : '';
 706 }
 707
 708 my %_month_names;
 709 BEGIN {
 710         %_month_names = (
 711                 jan => 0, feb => 1, mar => 2, apr => 3, may => 4, jun => 5,
 712                 jul => 6, aug => 7, sep => 8, oct => 9, nov => 10, dec => 11
 713         );
 714 }
 715
 716 # Should be in "date '+%a, %d %b %Y %T %z'" format as saved to lastgc, lastrefresh and lastchange
 717 # The leading "%a, " is optional, returns undef if unrecognized date.  This is also known as
 718 # RFC 2822 date format and git's '%cD', '%aD' and --date=rfc2822 format.
 719 # If the second argument is a SCALAR ref, its value will be set to the TZ offset in seconds
 720 sub parse_rfc2822_date {
 721         my $dstr = shift || '';
 722         my $tzoff = shift || '';
 723         $dstr = $1 if $dstr =~/^[^\s]+,\s*(.*)$/;
 724         return undef unless $dstr =~
 725                 /^\s*(\d{1,2})\s+([A-Za-z]{3})\s+(\d{4})\s+(\d{1,2}):(\d{2}):(\d{2})\s+([+-]\d{4})\s*$/;
 726         my ($d,$b,$Y,$H,$M,$S,$z) = ($1,$2,$3,$4,$5,$6,$7);
 727         my $m = $_month_names{lc($b)};
 728         return undef unless defined($m);
 729         my $seconds = timegm(0+$S, 0+$M, 0+$H, 0+$d, 0+$m, 0+$Y);
 730         my $offset = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
 731         $offset = -$offset if substr($z,0,1) eq '-';
 732         $$tzoff = $offset if ref($tzoff) eq 'SCALAR';
 733         return $seconds - $offset;
 734 }
 735
 736 # Will parse any supported date format.  Actually there are three formats
 737 # currently supported:
 738 #   1. RFC 2822 (uses parse_rfc2822_date)
 739 #   2. RFC 3339 / ISO 8601 (T may be ' ' or '_', 'Z' is optional or may be 'UTC', ':' optional in TZ)
 740 #   3. Same as #2 except no colons or hyphens allowed and hours MUST be 2 digits
 741 #   4. unix seconds since epoch with optional +/- trailing TZ (may not have a ':')
 742 # Returns undef if unsupported date.
 743 # If the second argument is a SCALAR ref, its value will be set to the TZ offset in seconds
 744 sub parse_any_date {
 745         my $dstr = shift || '';
 746         my $tzoff = shift || '';
 747         if ($dstr =~ /^\s*([-+]?\d+)(?:\s+([-+]\d{4}))?\s*$/) {
 748                 # Unix timestamp
 749                 my $ts = 0 + $1;
 750                 my $off = 0;
 751                 if ($2) {
 752                         my $z = $2;
 753                         $off = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
 754                         $off = -$off if substr($z,0,1) eq '-';
 755                 }
 756                 $$tzoff = $off if ref($tzoff) eq 'SCALAR';
 757                 return $ts;
 758         }
 759         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*$/ ||
 760             $dstr =~ /^\s*(\d{4})(\d{2})(\d{2})[Tt _](\d{2})(\d{2})(\d{2})(?:[ _]?([Zz]|[Uu][Tt][Cc]|(?:[-+]\d{2}\d{2})))?\s*$/) {
 761                 my ($Y,$m,$d,$H,$M,$S,$z) = ($1,$2,$3,$4,$5,$6,$7||'');
 762                 my $seconds = timegm(0+$S, 0+$M, 0+$H, 0+$d, $m-1, 0+$Y);
 763                 defined($z) && $z ne '' or $z = 'Z';
 764                 $z = uc($z);
 765                 $z =~ s/://;
 766                 substr($z,1,0) = '0' if length($z) == 4;
 767                 my $off = 0;
 768                 if ($z ne 'Z' && $z ne 'UTC') {
 769                         $off = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
 770                         $off = -$off if substr($z,0,1) eq '-';
 771                 }
 772                 $$tzoff = $off if ref($tzoff) eq 'SCALAR';
 773                 return $seconds - $off;
 774         }
 775         return parse_rfc2822_date($dstr, $tzoff);
 776 }
 777
 778 # Input is a number such as a minute interval
 779 # Return value is a random number between the input and 1.25*input
 780 # This can be used to randomize the update and gc operations a bit to avoid
 781 # having them all end up all clustered together
 782 sub rand_adjust {
 783         my $input = shift || 0;
 784         return $input unless $input;
 785         return $input + int(rand(0.25 * $input));
 786 }
 787
 788 # Open a pipe to a new sendmail process.  The '-i' option is always passed to
 789 # the new process followed by any addtional arguments passed in.  Note that
 790 # the sendmail process is only expected to understand the '-i', '-t' and '-f'
 791 # options.  Using any other options via this function is not guaranteed to work.
 792 # A list of recipients may follow the options.  Combining a list of recipients
 793 # with the '-t' option is not recommended.
 794 sub sendmail_pipe {
 795         return undef unless @_;
 796         die "\$Girocco::Config::sendmail_bin is unset or not executable!\n"
 797                 unless $Girocco::Config::sendmail_bin && -x $Girocco::Config::sendmail_bin;
 798         my $result = open(my $pipe, '|-', $Girocco::Config::sendmail_bin, '-i', @_);
 799         return $result ? $pipe : undef;
 800 }
 801
 802 # Open a pipe that works similarly to a mailer such as /usr/bin/mail in that
 803 # if the first argument is '-s', a subject line will be automatically added
 804 # (using the second argument as the subject).  Any remaining arguments are
 805 # expected to be recipient addresses that will be added to an explicit To:
 806 # line as well as passed on to sendmail_pipe.  In addition an
 807 # "Auto-Submitted: auto-generated" header is always added as well as a suitable
 808 # "From:" header.
 809 sub mailer_pipe {
 810         my $subject = undef;
 811         if (@_ >= 2 && $_[0] eq '-s') {
 812                 shift;
 813                 $subject = shift;
 814         }
 815         my $tolist = join(", ", @_);
 816         unshift(@_, '-f', $Girocco::Config::sender) if $Girocco::Config::sender;
 817         my $pipe = sendmail_pipe(@_);
 818         if ($pipe) {
 819                 print $pipe "From: \"$Girocco::Config::name\" ",
 820                         "($Girocco::Config::title) ",
 821                         "<$Girocco::Config::admin>\n";
 822                 print $pipe "To: $tolist\n";
 823                 print $pipe "Subject: $subject\n" if defined($subject);
 824                 print $pipe "MIME-Version: 1.0\n";
 825                 print $pipe "Content-Type: text/plain; charset=utf-8; format=fixed\n";
 826                 print $pipe "Content-Transfer-Encoding: 8bit\n";
 827                 print $pipe "X-Girocco: $Girocco::Config::gitweburl\n"
 828                         unless $Girocco::Config::suppress_x_girocco;
 829                 print $pipe "Auto-Submitted: auto-generated\n";
 830                 print $pipe "\n";
 831         }
 832         return $pipe;
 833 }
 834
 835 sub _goodval {
 836         my $val = shift;
 837         return undef unless defined($val);
 838         $val =~ s/[\r\n]+$//s;
 839         return undef unless $val =~ /^\d+$/;
 840         $val = 0 + $val;
 841         return undef unless $val >= 1;
 842         return $val;
 843 }
 844
 845 # Returns the number of "online" cpus or undef if undetermined
 846 sub online_cpus {
 847         my @confcpus = $^O eq "linux" ?
 848                 qw(_NPROCESSORS_ONLN NPROCESSORS_ONLN) :
 849                 qw(NPROCESSORS_ONLN _NPROCESSORS_ONLN) ;
 850         my $cpus = _goodval(get_cmd('getconf', $confcpus[0]));
 851         return $1 if defined($cpus) && $cpus =~ /^(\d+)$/;
 852         $cpus = _goodval(get_cmd('getconf', $confcpus[1]));
 853         return $1 if defined($cpus) && $cpus =~ /^(\d+)$/;
 854         if ($^O ne "linux") {
 855                 my @sysctls = qw(hw.ncpu);
 856                 unshift(@sysctls, qw(hw.availcpu)) if $^O eq "darwin";
 857                 foreach my $mib (@sysctls) {
 858                         $cpus = _goodval(get_cmd('sysctl', '-n', $mib));
 859                         return $1 if defined($cpus) && $cpus =~ /^(\d+)$/;
 860                 }
 861         }
 862         return undef;
 863 }
 864
 865 # Returns the system page size in bytes or undef if undetermined
 866 # This should never fail on a POSIX system
 867 sub sys_pagesize {
 868         use POSIX ":unistd_h";
 869         my $pagesize = sysconf(_SC_PAGESIZE);
 870         return undef unless defined($pagesize) && $pagesize =~ /^\d+$/;
 871         $pagesize = 0 + $pagesize;
 872         return undef unless $pagesize >= 256;
 873         return $pagesize;
 874 }
 875
 876 # Returns the amount of available physical memory in bytes
 877 # This may differ from the actual amount of physical memory installed
 878 # Returns undef if this cannot be determined
 879 sub sys_memsize {
 880         my $pagesize = sys_pagesize;
 881         if ($pagesize && $^O eq "linux") {
 882                 my $pages = _goodval(get_cmd('getconf', '_PHYS_PAGES'));
 883                 return $pagesize * $pages if $pages;
 884         }
 885         if ($^O ne "linux") {
 886                 my @sysctls = qw(hw.physmem64);
 887                 unshift(@sysctls, qw(hw.memsize)) if $^O eq "darwin";
 888                 foreach my $mib (@sysctls) {
 889                         my $memsize = _goodval(get_cmd('sysctl', '-n', $mib));
 890                         return $memsize if $memsize;
 891                 }
 892                 my $memsize32 = _goodval(get_cmd('sysctl', '-n', 'hw.physmem'));
 893                 return $memsize32 if $memsize32 && $memsize32 <= 2147483647;
 894                 if ($pagesize) {
 895                         my $pages = _goodval(get_cmd('sysctl', '-n', 'hw.availpages'));
 896                         return $pagesize * $pages if $pages;
 897                 }
 898                 return 2147483647 + 1 if $memsize32;
 899         }
 900         return undef;
 901 }
 902
 903 sub _get_max_conf_suffixed_size {
 904         my $conf = shift;
 905         return undef unless defined $conf && $conf =~ /^(\d+)([kKmMgG]?)$/;
 906         my ($val, $suffix) = (0+$1, lc($2));
 907         $val *= 1024 if $suffix eq 'k';
 908         $val *= 1024 * 1024 if $suffix eq 'm';
 909         $val *= 1024 * 1024 * 1024 if $suffix eq 'g';
 910         return $val;
 911 }
 912
 913 sub _make_suffixed_size {
 914         my $size = shift;
 915         return $size if $size % 1024;
 916         $size /= 1024;
 917         return "${size}k" if $size % 1024;
 918         $size /= 1024;
 919         return "${size}m" if $size % 1024;
 920         $size /= 1024;
 921         return "${size}g";
 922 }
 923
 924 # Return the value to pass to --window-memory= for git repack
 925 # If the system memory or number of CPUs cannot be determined, returns "1g"
 926 # Otherwise returns one third the available memory divided by the number of CPUs
 927 # but never more than 1 gigabyte or max_gc_window_memory_size.
 928 sub calc_windowmemory {
 929         my $cpus = online_cpus;
 930         my $memsize = sys_memsize;
 931         my $max = 1024 * 1024 * 1024;
 932         if ($cpus && $memsize) {
 933                 $max = int($memsize / 3 / $cpus);
 934                 $max = 1024 * 1024 * 1024 if $max >= 1024 * 1024 * 1024;
 935         }
 936         my $maxconf = _get_max_conf_suffixed_size($Girocco::Config::max_gc_window_memory_size);
 937         $max = $maxconf if defined($maxconf) && $maxconf && $max > $maxconf;
 938         return _make_suffixed_size($max);
 939 }
 940
 941 # Return the value to set as core.bigFileThreshold for git repack
 942 # If the system memory cannot be determined, returns "256m"
 943 # Otherwise returns the available memory divided by 16
 944 # but never more than 512 megabytes or max_gc_big_file_threshold_size.
 945 sub calc_bigfilethreshold {
 946         my $memsize = sys_memsize;
 947         my $max = 256 * 1024 * 1024;
 948         if ($memsize) {
 949                 $max = int($memsize / 16);
 950                 $max = 512 * 1024 * 1024 if $max >= 512 * 1024 * 1024;
 951         }
 952         my $maxconf = _get_max_conf_suffixed_size($Girocco::Config::max_gc_big_file_threshold_size);
 953         $max = $maxconf if defined($maxconf) && $maxconf && $max > $maxconf;
 954         return _make_suffixed_size($max);
 955 }
 956
 957 # Return the value to use when deciding whether or not to re-calculate object deltas
 958 # If there are no more than this many objects then deltas will be recomputed in
 959 # order to create more efficient pack files.  The new_delta_threshold value
 960 # is constrained to be at least 1000 * cpu cores and no more than 100000.
 961 # The default is sys_memsize rounded up to the nearest multiple of 256 MB and
 962 # then 5000 per 256 MB or 50000 if we cannot determine memory size but never
 963 # more than 100000 or less than 1000 * cpu cores.
 964 sub calc_redeltathreshold {
 965         my $cpus = online_cpus || 1;
 966         if (defined($Girocco::Config::new_delta_threshold) &&
 967             $Girocco::Config::new_delta_threshold =~ /^\d+/) {
 968                 my $ndt = 0 + $Girocco::Config::new_delta_threshold;
 969                 if ($ndt >= $cpus * 1000) {
 970                         return $ndt <= 100000 ? $ndt : 100000;
 971                 }
 972         }
 973         my $calcval = 50000;
 974         my $memsize = sys_memsize;
 975         if ($memsize) {
 976                 my $quantum = 256 * 1024 * 1024;
 977                 $calcval = 5000 * int(($memsize + ($quantum - 1)) / $quantum);
 978                 $calcval = 1000 * $cpus if $calcval < 1000 * $cpus;
 979                 $calcval = 100000 if $calcval > 100000;
 980         }
 981         return $calcval;
 982 }
 983
 984 # $1 => thing to test
 985 # $2 => optional directory, if given and -e "$2/$1$3", then return false
 986 # $3 => optional, defaults to ''
 987 sub has_reserved_suffix {
 988         no warnings; # avoid silly 'unsuccessful stat on filename with \n' warning
 989         my ($name, $dir, $ext) = @_;
 990         $ext = '' unless defined $ext;
 991         return 0 unless defined $name && $name =~ /\.([^.]+)$/;
 992         return 0 unless exists $Girocco::Config::reserved_suffixes{lc($1)};
 993         return 0 if defined $dir && -e "$dir/$name$ext";
 994         return 1;
 995 }
 996
 997 # mostly undoes effect of `use CGI::Carp qw(fatalsToBrowser);`
 998 # mostly undoes effect of `use CGI::Carp qw(warningsToBrowser);`
 999 sub noFatalsToBrowser {
1000         delete $SIG{__DIE__};
1001         delete $SIG{__WARN__};
1002         undef *CORE::GLOBAL::die;
1003         *CORE::GLOBAL::die = sub {
1004                 no warnings;
1005                 my $ec = (0+$!) || ($? >> 8) || 255;
1006                 $ec != ($ec & 0xff) and $ec = 255;
1007                 $ec |= 128 if !(0+$!) && ($? & 0xff);
1008                 my (undef, $fn, $li) = caller(0);
1009                 my $loc = " at " . $fn . " line " . $li . ".\n";
1010                 my $msg = "";
1011                 $msg = join("", @_) if @_;
1012                 $msg = "Died" if $msg eq "";
1013                 $msg .= $loc unless $msg =~ /\n$/;
1014                 die $msg if $^S;
1015                 printf STDERR "%s", $msg;
1016                 exit($ec);
1017         };
1018         undef *CORE::GLOBAL::warn;
1019         *CORE::GLOBAL::warn = sub {
1020                 no warnings;
1021                 my (undef, $fn, $li) = caller(0);
1022                 my $loc = " at " . $fn . " line " . $li . ".\n";
1023                 my $msg = "";
1024                 $msg = join("", @_) if @_;
1025                 $msg = "Warning: something's wrong" if $msg eq "";
1026                 $msg .= $loc unless $msg =~ /\n$/;
1027                 printf STDERR "%s", $msg;
1028         };
1029 }
1030
1031 # mimics Git's symref reading but only for HEAD
1032 # returns undef on failure otherwise an string that is
1033 # either an all-hex (lowercase) value or starts with "refs/"
1034 sub read_HEAD_ref {
1035         my $headpath = $_[0] . "/HEAD";
1036         if (-l $headpath) {
1037                 my $rl = readlink($headpath);
1038                 return defined($rl) && $rl =~ m,^refs/[^\x00-\x1f \x7f~^:\\*?[]+$, ? $rl : undef;
1039         }
1040         open my $fd, '<', $headpath or return undef;
1041         my $hv;
1042         {
1043                 local $/ = undef;
1044                 $hv = <$fd>;
1045         }
1046         close $fd;
1047         defined($hv) or return undef;
1048         chomp $hv;
1049         $hv =~ m,^ref:\s*(refs/[^\x00-\x1f \x7f~^:\\*?[]+)$, and return $1;
1050         $hv =~ m/^[0-9a-fA-F]{40,}$/ and return lc($hv);
1051         return undef;
1052 }
1053
1054 # same as read_HEAD_ref but returns undef
1055 # unless the result starts with "refs/"
1056 sub read_HEAD_symref {
1057         my $hv = read_HEAD_ref(@_);
1058         return defined($hv) && $hv =~ m,^refs/., ? $hv : undef;
1059 }
1060
1061 # similar to Git's test except that GIT_OBJECT_DIRECTORY is ignored
1062 sub is_git_dir {
1063         my $gd = shift;
1064         defined($gd) && $gd ne "" && -d $gd or return undef;
1065         -d "$gd/objects" && -x "$gd/objects" or return 0;
1066         -d "$gd/refs" && -x "$gd/refs" or return 0;
1067         if (-l "$gd/HEAD") {
1068                 my $rl = readlink("$gd/HEAD");
1069                 defined($rl) && $rl =~ m,^refs/., or return 0;
1070                 -e "$gd/HEAD" or return 1;
1071         }
1072         open my $fd, '<', "$gd/HEAD" or return 0;
1073         my $hv;
1074         {
1075                 local $/;
1076                 $hv = <$fd>;
1077         }
1078         close $fd;
1079         defined $hv or return 0;
1080         chomp $hv;
1081         $hv =~ m,^ref:\s*refs/., and return 1;
1082         return $hv =~ /^[0-9a-f]{40}/;
1083 }
1084
1085 # Returns a PATH properly prefixed which guarantees that Git is found and the
1086 # basedir/bin utilities are found as intended.  $ENV{PATH} is LEFT UNCHANGED!
1087 # Caller is responsible for assigning result to $ENV{PATH} or otherwise
1088 # arranging for it to be used.  If $ENV{PATH} already has the proper prefix
1089 # then it's returned as-is (making this function idempotent).
1090 # Will die if it cannot determine a suitable full PATH.
1091 # Result is cached so all calls after the first are practically free.
1092 my $var_git_exec_path;
1093 sub util_path {
1094         defined($Girocco::Config::var_git_exec_path) && $Girocco::Config::var_git_exec_path ne "" and
1095                 $var_git_exec_path = $Girocco::Config::var_git_exec_path;
1096         if (!defined($var_git_exec_path) || $var_git_exec_path eq "") {
1097                 defined($Girocco::Config::basedir) && $Girocco::Config::basedir ne "" &&
1098                 -d $Girocco::Config::basedir && -r _ && -x _ or
1099                         die "invalid \$Girocco::Config::basedir setting: $Girocco::Config::basedir\n";
1100                 my $varsfile = $Girocco::Config::basedir . "/shlib_vars.sh";
1101                 if (-f $varsfile && -r _) {
1102                         my $vars;
1103                         if (open $vars, '<', $varsfile) {
1104                                 # last value for var_git_exec_path wins
1105                                 while (<$vars>) {
1106                                         chomp;
1107                                         substr($_, 0, 19) eq "var_git_exec_path=\"" or next;
1108                                         substr($_, -1, 1) eq "\"" or next;
1109                                         my $xd = substr($_, 19, -1);
1110                                         $var_git_exec_path = $xd if -d $xd && -r _ && -x _;
1111                                 }
1112                                 close $vars;
1113                         }
1114                 }
1115                 if (!defined($var_git_exec_path)) {
1116                         my $xd = get_git("--exec-path");
1117                         $var_git_exec_path = $xd if defined($xd) &&
1118                                 (chomp $xd, $xd) ne "" && -d $xd && -r _ && -x _;
1119                 }
1120                 defined($var_git_exec_path) && $var_git_exec_path ne "" or
1121                         die "could not determine \$(git --exec-path) value\n";
1122                 $var_git_exec_path = $1 if $var_git_exec_path =~ m|^(/.+)$|;
1123         }
1124         my $prefix = "$var_git_exec_path:$Girocco::Config::basedir/bin:";
1125         if (substr($ENV{PATH}, 0, length($prefix)) eq $prefix) {
1126                 return $ENV{PATH};
1127         } else {
1128                 return $prefix . $ENV{PATH};
1129         }
1130 }
1131
1132 # Note that Perl performs a "shellish" test in the Perl_do_exec3 function from doio.c,
1133 # but it has slightly different semantics in that whitespace does not automatically
1134 # make something "shellish".  The semantics used here more closely match Git's
1135 # semantics so that Girocco will provide an interpretation more similar to Git's.
1136 sub is_shellish {
1137         return unless defined(local $_ = shift);
1138         return 1 if m#[][\$&*(){}'";:=\\|?<>~`\#\s]#; # contains metacharacters
1139         return 0; # probably not shellish
1140 }
1141
1142 # Works just like the shlib.sh function git_add_config
1143 # except it takes two arguments, first the variable name, second the value
1144 # For example: git_add_config("gc.auto", "0")
1145 # No extra quoting is performed!
1146 # If the name or value requires special quoting, it must be provided by the caller!
1147 # Note this function will only be effective when running Git 1.7.3 or later
1148 sub git_add_config {
1149         my ($name, $val) = @_;
1150         defined($name) && defined($val) or return;
1151         $name ne "" or return;
1152         my $gcp = $ENV{GIT_CONFIG_PARAMETERS};
1153         defined($gcp) or $gcp = '';
1154         $gcp eq "" or $gcp = $gcp . " ";
1155         $gcp .= "'" . $name . '=' . $val . "'";
1156         $ENV{GIT_CONFIG_PARAMETERS} = $gcp;
1157 }
1158
1159 {
1160         package Girocco::Util::JSON::Boolean;
1161         use overload '""' => \&strval;
1162         sub new {
1163                 my $class = shift || __PACKAGE__;
1164                 my $val = shift;
1165                 return bless \$val, $class;
1166         }
1167         sub strval {
1168                 return ${$_[0]};
1169         }
1170 }
1171
1172 # returns a reference to a suitable object that will
1173 # encode to "true" or "false" when passed to to_json
1174 # based on the value passed to this function
1175 # For example, `print to_json(json_bool(1))` prints `true`.
1176 sub json_bool {
1177         return Girocco::Util::JSON::Boolean->new($_[0]);
1178 }
1179
1180 # returns a utf8 encoded result that strictly conforms to
1181 # the JSON standard aka RFC 8259.
1182 # first argument is a scalar or a ref to a SCALAR, ARRAY or HASH
1183 # second argument, if true, requests a "pretty" result
1184 sub to_json {
1185         my ($val, $prt) = @_;
1186         $prt = 1 if $prt && !looks_like_number($prt);
1187         $prt = 0 unless $prt;
1188         return _json_value($val, 0+$prt, "");
1189 }
1190
1191 sub _json_value {
1192         my ($val, $prt, $ndt) = @_;
1193         defined($val) or return "null";
1194         $val = $$val if ref($val) eq 'SCALAR';
1195         my $r = ref($val);
1196         $r eq 'HASH' and return _json_hash($val, $prt, $ndt);
1197         $r eq 'ARRAY' and return _json_array($val, $prt, $ndt);
1198         $r eq 'Girocco::Util::JSON::Boolean' and
1199                 return $val ? "true" : "false";
1200         $r ne '' and $val = "".$val;
1201         looks_like_number($val) and return "".(0+$val);
1202         return _json_str("".$val);
1203 }
1204
1205 my %json_esc; BEGIN {%json_esc=(
1206         '\\' => '\\\\',
1207         '"'  => '\"',
1208         "\b" => '\b',
1209         "\t" => '\t',
1210         "\n" => '\n',
1211         "\f" => '\f',
1212         "\r" => '\r'
1213 )}
1214
1215 sub _json_str {
1216         my $val = shift;
1217         Encode::is_utf8($val) and utf8::encode($val);
1218         $val =~ s/([\\\042\b\t\n\f\r])/$json_esc{$1}/go;
1219         $val =~ s/([\x00-\x1f])/sprintf("\\u%04X",ord($1))/goe;
1220         return '"'.$val.'"';
1221 }
1222
1223 sub _json_array {
1224         my ($val, $prt, $ndt) = @_;
1225         return '[]' unless @{$val};
1226         my $ans = "[";
1227         $ans .= "\n" if $prt;
1228         my $odt = $ndt;
1229         $ndt .= "  ";
1230         for (my $i = 0; $i <= $#{$val}; ++$i) {
1231                 $ans .= $ndt if $prt;
1232                 $ans .= _json_value(${$val}[$i], $prt, $ndt);
1233                 $ans .= "," if $i < $#{$val};
1234                 $ans .= "\n" if $prt;
1235         }
1236         $ndt = $odt;
1237         $ans .= $ndt if $prt;
1238         $ans .= "]";
1239         return $ans;
1240 }
1241
1242 sub _json_hash {
1243         my ($val, $prt, $ndt) = @_;
1244         return '{}' unless %{$val};
1245         my $ans = "{";
1246         $ans .= "\n" if $prt;
1247         my $odt = $ndt;
1248         $ndt .= "  ";
1249         my @keys = sort(keys(%{$val}));
1250         for (my $i = 0; $i <= $#keys; ++$i) {
1251                 $ans .= $ndt if $prt;
1252                 $ans .= _json_str("".$keys[$i]).":";
1253                 $ans .= " " if $prt;
1254                 $ans .= _json_value(${$val}{$keys[$i]}, $prt, $ndt);
1255                 $ans .= "," if $i < $#keys;
1256                 $ans .= "\n" if $prt;
1257         }
1258         $ndt = $odt;
1259         $ans .= $ndt if $prt;
1260         $ans .= "}";
1261         return $ans;
1262 }
1263
1264 # returns undef on error and sets $@ (otherwise $@ cleared)
1265 # if the JSON string to decode is "null" then undef is returned and $@ eq ""
1266 # $_[0] -> string value to decode from JSON
1267 # $_[1] -> if true return integers instead of json_bool for true/false
1268 # $_[2] -> if true strings are utf8::encode'd (i.e. they're bytes not chars)
1269 # returns scalar which will be an ARRAY or HASH ref for JSON array or hash values
1270 # using to_json(from_json($json_value)) will somewhat "normalize" $json_value
1271 # (and optionally pretty it up) and always recombine valid surrogate pairs
1272 sub from_json {
1273         my $ans = undef;
1274         eval {$ans = _from_jsonx(@_)};
1275         return $ans;
1276 }
1277
1278 # will die on bad input
1279 sub _from_jsonx {
1280         my ($val, $nobool, $enc) = @_;
1281         defined($val) or return undef;
1282         my $l = length($val);
1283         pos($val) = 0;
1284         my $atom = _from_json_value(\$val, $l, $nobool, $enc);
1285         $val =~ /\G\s+/gc;
1286         pos($val) >= $l or
1287                 die "garbage found at offset ".pos($val);
1288         return $atom;
1289 }
1290
1291 sub _from_json_value {
1292         my ($val, $l, $nobool, $enc) = @_;
1293         $$val =~ /\G\s+/gc;
1294         my $c = substr($$val, pos($$val), 1);
1295         $c eq "" and die "unexpected end of input at offset ".pos($$val);
1296         $c eq "{" and return _from_json_hash($val, $l, $nobool, $enc);
1297         $c eq "[" and return _from_json_array($val, $l, $nobool, $enc);
1298         $c eq '"' and return _from_json_str($val, $enc);
1299         index("-0123456789", $c) >= 0 and do {
1300                 $$val =~ /\G(-?(?:0|[1-9]\d*)(?:\.\d+)?(?:[eE][-+]?\d+)?)/gc and
1301                         return int($1) == $1 ? int($1) : $1;
1302                 die "invalid JSON number at offset ".pos($$val);
1303         };
1304         $$val =~ /\Gnull\b/gc and return undef;
1305         $$val =~ /\Gtrue\b/gc and return $nobool?1:json_bool(1);
1306         $$val =~ /\Gfalse\b/gc and return $nobool?0:json_bool(0);
1307         die "invalid JSON value at offset ".pos($$val);
1308 }
1309
1310 my %json_unesc; BEGIN {%json_unesc=(
1311         '\\' => "\\",
1312         '"'  => '"',
1313         'b'  => "\b",
1314         't'  => "\t",
1315         'n'  => "\n",
1316         'f'  => "\f",
1317         'r'  => "\r"
1318 )}
1319
1320 sub _from_json_str {
1321         my ($val, $enc) = @_;
1322         my $opos = pos($$val);
1323         $$val =~ /\G\042((?:[^\\\042]|\\.)*)\042/gsc and
1324                 return _from_json_strval($1, $opos+1, $enc);
1325         die "invalid JSON string starting at offset $opos";
1326 }
1327
1328 sub _from_json_strval {
1329         my ($val, $pos, $enc) = @_;
1330         Encode::is_utf8($val) || utf8::decode($val) or
1331                 die "invalid UTF-8 string starting at offset $pos";
1332         $val =~ s{\\([\\\042btnfr]|u[0-9a-fA-F]{4})}{
1333                 substr($1,0,1) eq "u" ? &{sub{
1334                         my $c = hex(substr($1,1,4));
1335                         0xD800 <= $c && $c <= 0xDFFF ?
1336                                 "\\" . $1 :
1337                                 chr(hex(substr($1,1,4)))
1338                 }} : $json_unesc{$1}
1339         }goxe;
1340         $val =~ s{\\u([Dd][89AaBb][0-9a-fA-F]{2})\\u([Dd][CcDdEeFf][0-9a-fA-F]{2})}{
1341                 chr(( ((hex($1)&0x03FF)<<10) | (hex($2)&0x03FF) ) + 0x10000)
1342         }goxe;
1343         !Encode::is_utf8($val) || utf8::encode($val) if $enc;
1344         return $val;
1345 }
1346
1347 sub _from_json_array {
1348         my ($val, $l, $nobool, $enc) = @_;
1349         my @a = ();
1350         $$val =~ /\G\[/gc or die "expected '[' at offset ".pos($$val);
1351         my $wantcomma = 0;
1352         while (pos($$val) < $l && substr($$val, pos($$val), 1) ne "]") {
1353                 $$val =~ /\G\s+/gc and next;
1354                 !$wantcomma && substr($$val, pos($$val), 1) eq "," and
1355                         die "unexpected comma (,) in JSON array at offset ".pos($$val);
1356                 $wantcomma && !($$val =~ /\G,/gc) and
1357                         die "expected comma (,) or right-bracket (]) in JSON array at offset ".pos($$val);
1358                 push(@a, _from_json_value($val, $l, $nobool, $enc));
1359                 $wantcomma = 1;
1360         }
1361         $$val =~ /\G\]/gc or die "expected ']' at offset ".pos($$val);
1362         return \@a;
1363 }
1364
1365 sub _from_json_hash {
1366         my ($val, $l, $nobool, $enc) = @_;
1367         my %h = ();
1368         $$val =~ /\G\{/gc or die "expected '{' at offset ".pos($$val);
1369         my $wantc = "";
1370         my $k = undef;
1371         while (pos($$val) < $l && substr($$val, pos($$val), 1) ne "}") {
1372                 $$val =~ /\G\s+/gc and next;
1373                 !$wantc && index(":,", substr($$val, pos($$val), 1)) >= 0 and
1374                         die "unexpected colon (:) or comma (,) in JSON hash at offset ".pos($$val);
1375                 $wantc eq ":" && !($$val =~ /\G:/gc) and
1376                         die "expected colon (:) in JSON hash at offset ".pos($$val);
1377                 $wantc eq "," && !($$val =~ /\G,/gc) and
1378                         die "expected comma (,) or right-brace (}) in JSON hash at offset ".pos($$val);
1379                 $wantc and $$val =~ /\G\s+/gc;
1380                 $wantc eq "," and $wantc = "";
1381                 !$wantc && substr($$val, pos($$val), 1) ne '"' and
1382                         die "expected double-quote (\") in JSON hash at offset ".pos($$val);
1383                 !$wantc and do {
1384                         $k = _from_json_str($val, $enc);
1385                         $wantc = ":";
1386                         next;
1387                 };
1388                 $h{$k} = _from_json_value($val, $l, $nobool, $enc);
1389                 $wantc = ",";
1390         }
1391         $wantc ne ":" or die "expected ':' at offset ".pos($$val);
1392         $$val =~ /\G\}/gc or die "expected '}' at offset ".pos($$val);
1393         return \%h;
1394 }
1395
1396 # $_[0] -> full absolute path to a git ".git" directory
1397 # $_[1] -> "old" ref hash value
1398 # $_[2] -> "new" ref hash value
1399 # returns:
1400 #   scalar context: "..." -- if forced ref update detected (i.e. NOT a fast-forward)
1401 #                   ".."  -- any other condition (i.e. fast-forward/creation/deletion/no change/etc.)
1402 #   array context: [0] -> scalar context result
1403 #                  [1] -> true value if a git command had to be run
1404 sub ref_indicator {
1405         return '..' unless defined($_[0]);
1406         my ($git_dir, $old, $new) = @_;
1407         return '..' unless defined($old) && defined($new) && $old !~ /^0+$/ && $new !~ /^0+$/ && $old ne $new;
1408         # In many cases `git merge-base` is slower than this even if using the
1409         # `--is-ancestor` option available since Git 1.8.0, but it's never faster
1410         my $ans = get_git("--git-dir=$git_dir", "rev-list", "-n", "1", "^$new^0", "$old^0", "--") ? '...' : '..';
1411         return wantarray ? ($ans, 1) : $ans;
1412 }
1413
1414 # return the token key to use for the passed in category
1415 # if there is no such token or it cannot be read or is invalid
1416 # then silently return undef
1417 # category names must currently be 32 or fewer alphanumeric
1418 # characters where the first must be an alpha char
1419 # $_[0] -> category name
1420 sub get_token_key {
1421         my $cname = shift;
1422         defined($cname) or return undef;
1423         $cname = lc($cname);
1424         $cname =~ /^([a-z][a-z0-9]{0,31})$/ or return undef;
1425         $cname = $1;
1426         my $tf = $Girocco::Config::certsdir . "/tokenkeys/$cname.tky";
1427         -e $tf && -f _ && -r _ && -s _ or return undef;
1428         my $fh;
1429         open $fh, '<', $tf or return undef;
1430         my $tk = <$fh>;
1431         close $fh;
1432         defined($tk) or return undef;
1433         chomp($tk);
1434         $tk =~ /^([A-Za-z0-9_-]{48})$/ or return undef;
1435         return $1;
1436 }
1437
1438 # just like create_timed_token except that
1439 # the first argument is a category name instead of
1440 # the actual HMAC "secret"
1441 # $_[0] -> category name to pass to get_token_key
1442 # $_[1] -> optional instance info to include in "text"
1443 # $_[2] -> duration of validity in seconds (5..2147483647)
1444 # $_[3] -> optional time stamp (secs since unix Epoch)
1445 #          if not provided, current time is used
1446 # Returns a base64_url token (no trailing '='s) that is
1447 # valid starting at $_[3] and expires $_[2] seconds after $_[3].
1448 # Unless get_token_key fails in which case it returns undef.
1449 #
1450 sub get_timed_token {
1451         my ($catg, $extra, $duration, $start) = @_;
1452         my $tk = get_token_key($catg);
1453         defined($tk) && $tk ne "" or return undef;
1454         return create_timed_token($tk, $extra, $duration, $start);
1455 }
1456
1457 # return a hidden "token" <input /> field if the token ($_[0])
1458 # can be read, otherwise the empty string "".
1459 # $_[0] -> the token category (passed to get_token_key)
1460 # $_[1] -> the optional instance info (passed to create_timed_token)
1461 # $_[2] -> the duration of validity (passed to create_timed_token)
1462 # $_[3] -> optional name of field (defaults to "token")
1463 # returns a "hidden" XHTML input element or the empty string if
1464 # get_timed_token fails.  The token starting time will be the
1465 # current time.
1466 #
1467 sub get_token_field {
1468         my ($catg, $extra, $duration, $name) = @_;
1469         defined($name) && $name ne "" or $name = "token";
1470         my $tt = get_timed_token($catg, $extra, $duration);
1471         defined($tt) && $tt ne "" or return "";
1472         return "<input type=\"hidden\" name=\"$name\" value=\"$tt\" />";
1473 }
1474
1475 # just like verify_timed_token except that
1476 # the second argument is a category name instead of
1477 # the actual HMAC "secret"
1478 # $_[0] -> a create_timed_token/get_timed_token to check
1479 # $_[1] -> category name to pass to get_token_key
1480 # $_[2] -> optional instance info to include in "text"
1481 # $_[3] -> duration of validity in seconds (5..2147483647)
1482 # $_[4] -> optional time stamp (secs since unix Epoch)
1483 #          if not provided, current time is used
1484 # Returns true if $_[4] falls within the token's validity range
1485 # Returns false for a bad or expired token
1486 sub check_timed_token {
1487         my ($token, $catg, $extra, $duration, $start) = @_;
1488         my $tk = get_token_key($catg);
1489         defined($tk) && $tk ne "" or return undef;
1490         return verify_timed_token($token, $tk, $extra, $duration, $start);
1491 }
1492
1493 # similar to the shlib.sh function v_get_proj_from_dir but different details
1494 # attempt to convert the first argument interpreted as a full path name to
1495 # a Girocco project name.  Unlike v_get_proj_from_dir, there's no magic
1496 # "_external/..." name fallback if not found.
1497 # $_[0] -> directory name to translate, relative to getcwd if not absolute
1498 # Returns name of existing Girocco project on success, undef on failure
1499 # Minor quibbles are handled (e.g. trailing '.git' omitted and shouldn't have been)
1500 # If the resolved absolute path ends with "/.git" and that's a "gitdir: " file
1501 # that will be followed too.
1502 # And finally, if we seem to have ended up in a worktree, that will be handled too
1503 sub get_project_from_dir {
1504         use Cwd qw(realpath);
1505         use File::Basename qw(dirname);
1506         require Girocco::Project;
1507         my $path = shift;
1508         defined($path) && $path ne "" or $path = ".";
1509         $path =~ s{/+$}{}; $path ne "" or $path = "/";
1510         my $fallback = sub {
1511                 my $fallback = $path;
1512                 # if a top-level working tree directory was specified
1513                 # take that to mean its associated .git dir otherwise
1514                 # if a sibling directory with a ".git" extension exists
1515                 # such as where forked projects are involved, try that
1516                 if ($path !~ /\/\.git$/ && -e "$fallback/.git") {
1517                         $fallback .= "/.git";
1518                 } else {
1519                         (my $test = $path) =~ s/\.$//;
1520                         if ($test !~ /\.git$/ && -d "$test.git") {
1521                                 # project fork directory trees always
1522                                 # use bare repositories; do NOT check
1523                                 # for a "$test.git/.git" here;
1524                                 # but a 2nd fallback round will!
1525                                 $fallback = "$test.git";
1526                         }
1527                 }
1528                 $fallback ne $path && -e $fallback or return undef;
1529                 return get_project_from_dir($fallback);
1530         };
1531         my $rpath = realpath($path);
1532         defined($rpath) && -e $rpath or return &$fallback;
1533         if ($rpath =~ /\/\.git$/ && -f $rpath && -s _) {
1534                 # grumble
1535                 # see if it's a gitdir: link (allowing relative ones)
1536                 # and pick up its destination
1537                 # no fallbacks in here since an existing ".git"
1538                 # was found and it was a file not a dir
1539                 open my $gdf, '<', $rpath or return undef;
1540                 my $gdline = <$gdf>;
1541                 close $gdf;
1542                 defined($gdline) && $gdline =~ /^gitdir:\s*([^\s].*)$/
1543                         or return undef;
1544                 (my $gitdir = $1) =~ s/\s+$//;
1545                 if (substr($gitdir, 0, 1) ne "/") {
1546                         # it's relative
1547                         $gitdir = dirname($rpath)."/".$gitdir;
1548                 }
1549                 -e $gitdir or return undef;
1550                 $gitdir = realpath($gitdir);
1551                 # a gitdir: link must point to a real directory
1552                 defined($gitdir) && -d $gitdir or return undef;
1553                 $rpath = $gitdir;
1554         }
1555         # an existing directory is required at this point
1556         # if it's an existing not-a-directory, no fallback
1557         -d $rpath or return undef;
1558         if (!is_git_dir($rpath)) {
1559                 # grumble
1560                 # see if it might be a worktree
1561                 if (-f "$rpath/HEAD" && -s _ && -f "$rpath/commondir" && -s _) {
1562                         open my $cdf, '<', "$rpath/commondir" or return &$fallback;
1563                         my $cdl = <$cdf>;
1564                         close $cdf;
1565                         defined($cdl) && $cdl ne "" or return &$fallback;
1566                         $cdl =~ s/^\s+//; $cdl =~ s/\s+$//;
1567                         $cdl ne "" or return &$fallback;
1568                         # for now require "../.." for safety
1569                         $cdl eq "../.." or return &$fallback;
1570                         $rpath = dirname(dirname($rpath));
1571                         is_git_dir($rpath) or return &$fallback;
1572                 } else {
1573                         return &$fallback; # yes, try a ".git" suffix fallback
1574                 }
1575         }
1576         # at this point $rpath is a "realpath" to an existing directory
1577         # that appears to be a non-worktree $GIT_DIR -- no more fallbacks
1578         # try the quick check first
1579         my $rrr = realpath($Girocco::Config::reporoot);
1580         defined($rrr) && $rrr ne "" or return undef;
1581         if ($rpath =~ m{^\Q$rrr\E/(.+)$}) {
1582                 (my $proj = $1) =~ s/\.git$//;
1583                 return $proj ne "" && Girocco::Project::does_exist($proj, 1)
1584                         ? $proj : undef;
1585         }
1586         # finally, attempt to look up the path in gitdir.list if all else fails
1587         my $gdlp = "$Girocco::Config::projlist_cache_dir/gitdir.list";
1588         -f $gdlp && -s _ or return undef;
1589         my $projname = undef;
1590         open my $gdlf, '<', $gdlp or return undef;
1591         while (<$gdlf>) {
1592                 /^([^\s]+)\s+([^\s].*)$/ or next;
1593                 $2 eq $rpath or next;
1594                 $projname = $1;
1595                 last;
1596         }
1597         close $gdlf;
1598         defined($projname) && $projname ne "" && Girocco::Project::does_exist($projname, 1)
1599                 or $projname = undef;
1600         return $projname;
1601 }
1602
1603 1;