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