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