Girocco/Util.pm

   1 package Girocco::Util;
   2
   3 use 5.008;
   4 use strict;
   5 use warnings;
   6
   7 use Girocco::Config;
   8 use Time::Local;
   9 use Encode;
  10
  11 BEGIN {
  12         use base qw(Exporter);
  13         our @EXPORT = qw(get_git scrypt jailed_file sendmail_pipe mailer_pipe
  14                          lock_file unlock_file valid_tag rand_adjust
  15                          filedb_atomic_append filedb_atomic_edit filedb_grep
  16                          filedb_atomic_grep valid_email valid_email_multi
  17                          valid_repo_url valid_web_url url_base url_path url_server
  18                          projects_html_list parse_rfc2822_date parse_any_date
  19                          extract_url_hostname is_dns_hostname is_our_hostname
  20                          get_cmd online_cpus sys_pagesize sys_memsize
  21                          calc_windowmemory to_utf8 capture_command human_size
  22                          calc_bigfilethreshold has_reserved_suffix
  23                          noFatalsToBrowser calc_redeltathreshold);
  24 }
  25
  26 my $encoder;
  27 BEGIN {
  28         $encoder = Encode::find_encoding('Windows-1252') ||
  29                    Encode::find_encoding('ISO-8859-1') or
  30                    die "failed to load ISO-8859-1 encoder\n";
  31 }
  32
  33 sub to_utf8($;$) {
  34         my ($str, $encode) = @_;
  35         return undef unless defined $str;
  36         my $ans;
  37         if (Encode::is_utf8($str) || utf8::decode($str)) {
  38                 $ans = $str;
  39         } else {
  40                 $ans = $encoder->decode($str, Encode::FB_DEFAULT);
  41         }
  42         utf8::encode($ans) if $encode;
  43         return $ans;
  44 }
  45
  46 BEGIN {require "Girocco/extra/capture_command.pl"}
  47
  48 # Return the entire output sent to stdout from running a command
  49 # Any output the command sends to stderr is discarded
  50 # Returns undef if there was an error running the command (see $!)
  51 sub get_cmd {
  52         my ($status, $result) = capture_command(1, undef, @_);
  53         return defined($status) && $status == 0 ? $result : undef;
  54 }
  55
  56 # Same as get_cmd except configured git binary is automatically provided
  57 # as the first argument to get_cmd
  58 sub get_git {
  59         return get_cmd($Girocco::Config::git_bin, @_);
  60 }
  61
  62 sub scrypt {
  63         my ($pwd) = @_;
  64         crypt($pwd||'', join ('', ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]));
  65 }
  66
  67 sub jailed_file {
  68         my ($filename) = @_;
  69         $filename =~ s,^/,,;
  70         $Girocco::Config::chroot."/$filename";
  71 }
  72
  73 sub lock_file {
  74         my ($path) = @_;
  75
  76         $path .= '.lock';
  77
  78         use Errno qw(EEXIST);
  79         use Fcntl qw(O_WRONLY O_CREAT O_EXCL);
  80         use IO::Handle;
  81         my $handle = new IO::Handle;
  82
  83         unless (sysopen($handle, $path, O_WRONLY|O_CREAT|O_EXCL)) {
  84                 my $cnt = 0;
  85                 while (not sysopen($handle, $path, O_WRONLY|O_CREAT|O_EXCL)) {
  86                         ($! == EEXIST) or die "$path open failed: $!";
  87                         ($cnt++ < 16) or die "$path open failed: cannot open lockfile";
  88                         sleep(1);
  89                 }
  90         }
  91         # XXX: filedb-specific
  92         chmod 0664, $path or die "$path g+w failed: $!";
  93
  94         $handle;
  95 }
  96
  97 sub _is_passwd_file {
  98         return defined($_[0]) && $_[0] eq jailed_file('/etc/passwd');
  99 }
 100
 101 sub _run_update_pwd_db {
 102         my ($path, $updatearg) = @_;
 103         my @cmd = ($Girocco::Config::basedir.'/bin/update-pwd-db', "$path");
 104         push(@cmd, $updatearg) if $updatearg;
 105         system(@cmd) == 0 or die "update-pwd-db failed: $?";
 106 }
 107
 108 sub unlock_file {
 109         my ($path, $noreplace, $updatearg) = @_;
 110
 111         if (!$noreplace) {
 112                 _run_update_pwd_db("$path.lock", $updatearg)
 113                         if $Girocco::Config::update_pwd_db && _is_passwd_file($path);
 114                 rename "$path.lock", $path or die "$path unlock failed: $!";
 115         } else {
 116                 unlink "$path.lock" or die "$path unlock failed: $!";
 117         }
 118 }
 119
 120 sub filedb_atomic_append {
 121         my ($file, $line, $updatearg) = @_;
 122         my $id = 65536;
 123
 124         open my $src, '<', $file or die "$file open for reading failed: $!";
 125         my $dst = lock_file($file);
 126
 127         while (<$src>) {
 128                 my $aid = (split /:/)[2];
 129                 $id = $aid + 1 if ($aid >= $id);
 130
 131                 print $dst $_ or die "$file(l) write failed: $!";
 132         }
 133
 134         $line =~ s/\\i/$id/g;
 135         print $dst "$line\n" or die "$file(l) write failed: $!";
 136
 137         close $dst or die "$file(l) close failed: $!";
 138         close $src;
 139
 140         unlock_file($file, 0, $updatearg);
 141
 142         $id;
 143 }
 144
 145 sub filedb_atomic_edit {
 146         my ($file, $fn, $updatearg) = @_;
 147
 148         open my $src, '<', $file or die "$file open for reading failed: $!";
 149         my $dst = lock_file($file);
 150
 151         while (<$src>) {
 152                 print $dst $fn->($_) or die "$file(l) write failed: $!";
 153         }
 154
 155         close $dst or die "$file(l) close failed: $!";
 156         close $src;
 157
 158         unlock_file($file, 0, $updatearg);
 159 }
 160
 161 sub filedb_atomic_grep {
 162         my ($file, $fn) = @_;
 163         my @results = ();
 164
 165         open my $src, '<', $file or die "$file open for reading failed: $!";
 166         my $dst = lock_file($file);
 167
 168         while (<$src>) {
 169                 my $result = $fn->($_);
 170                 push(@results, $result) if $result;
 171         }
 172
 173         close $dst or die "$file(l) close failed: $!";
 174         close $src;
 175
 176         unlock_file($file, 1);
 177         return @results;
 178 }
 179
 180 sub filedb_grep {
 181         my ($file, $fn) = @_;
 182         my @results = ();
 183
 184         open my $src, '<', $file or die "$file open for reading failed: $!";
 185
 186         while (<$src>) {
 187                 my $result = $fn->($_);
 188                 push(@results, $result) if $result;
 189         }
 190
 191         close $src;
 192
 193         return @results;
 194 }
 195
 196 sub valid_email {
 197         my $email = shift;
 198         defined($email) or $email = '';
 199         return $email =~ /^[a-zA-Z0-9+._-]+@[a-zA-Z0-9.-]+$/;
 200 }
 201
 202 sub valid_email_multi {
 203         my $email_multi = shift;
 204         defined($email_multi) or $email_multi = '';
 205         # More relaxed, we just want to avoid too dangerous characters.
 206         return $email_multi =~ /^[a-zA-Z0-9+._, \@-]+$/;
 207 }
 208
 209 sub valid_web_url {
 210         my $url = shift;
 211         defined($url) or $url = '';
 212         return $url =~
 213                 /^https?:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~:?&=;-]*)?(#[a-zA-Z0-9._-]+)?$/;
 214 }
 215
 216 sub valid_repo_url {
 217         my $url = shift || '';
 218         # Currently neither username nor password is allowed in the URL and IPv6
 219         # literal addresses are not accepted either.
 220         $Girocco::Config::mirror_svn &&
 221                 $url =~ /^svn(\+https?)?:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/os
 222                 and return 1;
 223         $Girocco::Config::mirror_darcs &&
 224                 $url =~ /^darcs:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/os
 225                 and return 1;
 226         $Girocco::Config::mirror_bzr &&
 227                 $url =~ /^bzr:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/os
 228                 and return 1;
 229         $Girocco::Config::mirror_hg &&
 230                 $url =~ /^hg\+https?:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/os
 231                 and return 1;
 232         return $url =~  /^(https?|git):\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/;
 233 }
 234
 235 sub extract_url_hostname {
 236         my $url = shift || '';
 237         if ($url =~ m,^bzr://,) {
 238                 $url =~ s,^bzr://,,;
 239                 return 'launchpad.net' if $url =~ /^lp:/;
 240         }
 241         return undef unless $url =~ m,^[A-Za-z0-9+.-]+://[^/],;
 242         $url =~ s,^[A-Za-z0-9+.-]+://,,;
 243         $url =~ s,^([^/]+).*$,$1,;
 244         $url =~ s/:[0-9]*$//;
 245         $url =~ s/^[^\@]*[\@]//;
 246         return $url ? $url : undef;
 247 }
 248
 249 # See these RFCs:
 250 #   RFC 1034 section 3.5
 251 #   RFC 1123 section 2.1
 252 #   RFC 1738 section 3.1
 253 #   RFC 2606 sections 2 & 3
 254 #   RFC 3986 section 3.2.2
 255 sub is_dns_hostname {
 256         my $host = shift;
 257         defined($host) or $host = '';
 258         return 0 if $host eq '' || $host =~ /\s/;
 259         # first remove a trailing '.'
 260         $host =~ s/\.$//;
 261         return 0 if length($host) > 255;
 262         my $octet = '(?:\d|[1-9]\d|1\d{2}|2[0-4]\d|25[0-5])';
 263         return 0 if $host =~ /^$octet\.$octet\.$octet\.$octet$/o;
 264         my @labels = split(/[.]/, $host, -1);
 265         return 0 unless @labels && @labels >= $Girocco::Config::min_dns_labels;
 266         # now check each label
 267         foreach my $label (@labels) {
 268                 return 0 unless length($label) > 0 && length($label) <= 63;
 269                 return 0 unless $label =~ /^[A-Za-z0-9](?:[A-Za-z0-9-]*[A-Za-z0-9])?$/;
 270         }
 271         # disallow RFC 2606 names provided at least two labels are present
 272         if (@labels >= 2) {
 273                 my $tld = lc($labels[-1]);
 274                 return 0 if
 275                     $tld eq 'test' ||
 276                     $tld eq 'example' ||
 277                     $tld eq 'invalid' ||
 278                     $tld eq 'localhost';
 279                 my $sld = lc($labels[-2]);
 280                 return 0 if $sld eq 'example' &&
 281                     ($tld eq 'com' || $tld eq 'net' || $tld eq 'org');
 282         }
 283         return 1;
 284 }
 285
 286 sub is_our_hostname {
 287         my $test = shift || '';
 288         $test =~ s/\.$//;
 289         my %names = ();
 290         my @urls = (
 291                 $Girocco::Config::gitweburl,
 292                 $Girocco::Config::gitwebfiles,
 293                 $Girocco::Config::webadmurl,
 294                 $Girocco::Config::bundlesurl,
 295                 $Girocco::Config::htmlurl,
 296                 $Girocco::Config::httppullurl,
 297                 $Girocco::Config::httpbundleurl,
 298                 $Girocco::Config::httpspushurl,
 299                 $Girocco::Config::gitpullurl,
 300                 $Girocco::Config::pushurl
 301         );
 302         foreach my $url (@urls) {
 303                 if ($url) {
 304                         my $host = extract_url_hostname($url);
 305                         if (defined($host)) {
 306                                 $host =~ s/\.$//;
 307                                 $names{lc($host)} = 1;
 308                         }
 309                 }
 310         }
 311         return $names{lc($test)} ? 1 : 0;
 312 }
 313
 314 my (%_oktags, %_badtags);
 315 BEGIN {
 316         # entries MUST be all lowercase to be effective
 317         %_oktags = (
 318         # These are always okay (a "whitelist") even if they would otherwise
 319         # not be allowed
 320         ".net"=>1, "2d"=>1, "3d"=>1, "6502"=>1, "68000"=>1, "68008"=>1,
 321         "68010"=>1, "68020"=>1, "68030"=>1, "68040"=>1, "68060"=>1,
 322         "8086"=>1, "80286"=>1,  "80386"=>1, "80486"=>1, "80586"=>1,
 323         c=>1, cc=>1, make=>1, www=>1, x=>1
 324         );
 325         map({$_oktags{lc($_)}=1} @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.
 376 sub valid_tag {
 377         local $_ = $_[0] || '';
 378         return 1 if $_oktags{lc($_)};
 379         return 0 unless /^[a-zA-Z][a-zA-Z0-9:.+#_-]+$/;
 380         return 0 if $_badtags{lc($_)};
 381         return 0 if /^(.)\1+$/;
 382         return length($_) <= 32 ? 1 : 0;
 383 }
 384
 385 # If the passed in argument looks like a URL, return only the stuff up through
 386 # the host:port part otherwise return the entire argument.
 387 sub url_base {
 388         my $url = shift || '';
 389         # See RFC 3968
 390         $url = $1.$2.$3.$4 if $url =~ m,^( [A-Za-z][A-Za-z0-9+.-]*: ) # scheme
 391                 ( // )          # // separator
 392                 ((?:[^\@]+\@)?) # optional userinfo
 393                 ( [^/?#]+ )     # host and port
 394                 (?:[/?#].*)?$,x; # path and optional query string and/or anchor
 395         return $url;
 396 }
 397
 398 # If the passed in argument looks like a URL, return only the stuff following
 399 # the host:port part otherwise return the entire argument.
 400 # If the optional second argument is true, the returned value will have '/'
 401 # appended if it does not already end in '/'.
 402 sub url_path {
 403         my $url = shift || '';
 404         my $add_slash = shift || 0;
 405         # See RFC 3968
 406         $url = $1 if $url =~ m,^(?: [A-Za-z][A-Za-z0-9+.-]*: ) # scheme
 407                 (?: // )        # // separator
 408                 (?: [^\@]+\@ )? # optional userinfo
 409                 (?: [^/?#]+ )   # host and port
 410                 ((?:[/?#].*)?)$,x; # path and optional query string and/or anchor
 411         $url .= '/' if $add_slash && $url !~ m|/$|;
 412         return $url;
 413 }
 414
 415 # If both SERVER_NAME and SERVER_PORT are set pass the argument through url_path
 416 # and then prefix it with the appropriate scheme (HTTPS=?on), host and port and
 417 # return it.  If a something that doesn't look like it could be the start of a
 418 # URL path comes back from url_path or SERVER_NAME is a link-local IPv6 address
 419 # then just return the argument unchanged.
 420 sub url_server {
 421         my $url = shift || '';
 422         my $path = url_path($url);
 423         return $url unless $path eq '' || $path =~ m|^[/?#]|;
 424         return $url unless $ENV{'SERVER_NAME'} && $ENV{'SERVER_PORT'} &&
 425                 $ENV{'SERVER_PORT'} =~ /^[1-9][0-9]{0,4}$/;
 426         return $url if $ENV{'SERVER_NAME'} =~ /^[[]?fe80:/i;
 427         my $server = $ENV{'SERVER_NAME'};
 428         # Deal with Apache bug where IPv6 literal server names do not include
 429         # the required surrounding '[' and ']' characters
 430         $server = '[' . $server . ']' if $server =~ /:/ && $server !~ /^[[]/;
 431         my $ishttps = $ENV{'HTTPS'} && $ENV{'HTTPS'} =~ /^on$/i;
 432         my $portnum = 0 + $ENV{'SERVER_PORT'};
 433         my $port = '';
 434         if (($ishttps && $portnum != 443) || (!$ishttps && $portnum != 80)) {
 435                 $port = ':' . $portnum;
 436         }
 437         return 'http' . ($ishttps ? 's' : '') . '://' . $server . $port . $path;
 438 }
 439
 440 # Returns the number rounded to the nearest tenths.  The ".d" part will be
 441 # excluded if it's ".0" unless the optional second argument is true
 442 sub _tenths {
 443         my $v = shift;
 444         my $use0 = shift;
 445         $v *= 10;
 446         $v += 0.5;
 447         $v = int($v);
 448         return '' . int($v/10) unless $v % 10 || $use0;
 449         return '' . int($v/10) . '.' . ($v%10);
 450 }
 451
 452 # Returns a human-readable size string (e.g. '1.5 MiB') for the value
 453 # (in bytes) passed in.  Returns '0' for undefined or 0 or not all digits.
 454 # Otherwise returns '1 KiB' for < 1024, or else a number rounded to the
 455 # nearest tenths of a KiB, MiB or GiB.
 456 sub human_size {
 457         my $v = shift || 0;
 458         return "0" unless $v && $v =~ /^\d+$/;
 459         return "1 KiB" unless $v > 1024;
 460         $v /= 1024;
 461         return _tenths($v) . " KiB" if $v < 1024;
 462         $v /= 1024;
 463         return _tenths($v) . " MiB" if $v < 1024;
 464         $v /= 1024;
 465         return _tenths($v) . " GiB";
 466 }
 467
 468 sub _escapeHTML {
 469         my $str = shift;
 470         $str =~ s/\&/\&amp;/gs;
 471         $str =~ s/\</\&lt;/gs;
 472         $str =~ s/\>/\&gt;/gs;
 473         $str =~ s/\"/\&quot;/gs; #"
 474         return $str;
 475 }
 476
 477 # create relative time string from passed in age in seconds
 478 sub _rel_age {
 479         my $age = shift;
 480         my $age_str;
 481
 482         if ($age > 60*60*24*365*2) {
 483                 $age_str = (int $age/60/60/24/365);
 484                 $age_str .= " years ago";
 485         } elsif ($age > 60*60*24*(365/12)*2) {
 486                 $age_str = int $age/60/60/24/(365/12);
 487                 $age_str .= " months ago";
 488         } elsif ($age > 60*60*24*7*2) {
 489                 $age_str = int $age/60/60/24/7;
 490                 $age_str .= " weeks ago";
 491         } elsif ($age > 60*60*24*2) {
 492                 $age_str = int $age/60/60/24;
 493                 $age_str .= " days ago";
 494         } elsif ($age > 60*60*2) {
 495                 $age_str = int $age/60/60;
 496                 $age_str .= " hours ago";
 497         } elsif ($age > 60*2) {
 498                 $age_str = int $age/60;
 499                 $age_str .= " mins ago";
 500         } elsif ($age > 2) {
 501                 $age_str = int $age;
 502                 $age_str .= " secs ago";
 503         } elsif ($age >= 0) {
 504                 $age_str = "right now";
 505         } else {
 506                 $age_str = "future time";
 507         }
 508         return $age_str;
 509 }
 510
 511 # create relative time string from passed in idle in seconds
 512 sub _rel_idle {
 513         my $idle_str = _rel_age(shift);
 514         $idle_str =~ s/ ago//;
 515         $idle_str = "not at all" if $idle_str eq "right now";
 516         return $idle_str;
 517 }
 518
 519 sub _strftime {
 520         use POSIX qw(strftime);
 521         my ($fmt, $secs, $zonesecs) = @_;
 522         my ($S,$M,$H,$d,$m,$y) = gmtime($secs + $zonesecs);
 523         $zonesecs = int($zonesecs / 60);
 524         $fmt =~ s/%z/\$z/g;
 525         my $ans = strftime($fmt, $S, $M, $H, $d, $m, $y, -1, -1, -1);
 526         my $z;
 527         if ($zonesecs < 0) {
 528                 $z = "-";
 529                 $zonesecs = -$zonesecs;
 530         } else {
 531                 $z = "+";
 532         }
 533         $z .= sprintf("%02d%02d", int($zonesecs/60), $zonesecs % 60);
 534         $ans =~ s/\$z/$z/g;
 535         return $ans;
 536 }
 537
 538 # Take a list of project names and produce a nicely formated table that
 539 # includes owner links and descriptions.  If the list is empty returns ''.
 540 # The first argument may be a hash ref that contains options.  The following
 541 # options are available:
 542 #   target  -- sets the target value of the owner link
 543 #   emptyok -- if true returns an empty table rather than ''
 544 #   sizecol -- if true include a human-readable size column
 545 #   typecol -- if true include type column with hover info
 546 #   changed -- if true include a changed and idle column
 547 sub projects_html_list {
 548         my $options = {};
 549         if (defined($_[0]) && ref($_[0]) eq 'HASH') {
 550                 $options = shift;
 551         }
 552         return '' unless @_ || (defined($options->{emptyok}) && $options->{emptyok});
 553         require Girocco::Project;
 554         my $count = 0;
 555         my $target = '';
 556         $target = " target=\""._escapeHTML($options->{target})."\""
 557                 if defined($options->{target});
 558         my $withsize = defined($options->{sizecol}) && $options->{sizecol};
 559         my $withtype = defined($options->{typecol}) && $options->{typecol};
 560         my $withchanged = defined($options->{changed}) && $options->{changed};
 561         my $sizehead = '';
 562         $sizehead = substr(<<EOT, 0, -1) if $withsize;
 563 <th class="sizecol"><span class="hover">Size<span><span class="head">Size</span
 564 />Fork size excludes objects borrowed from the parent.</span></span></th
 565 >
 566 EOT
 567         my $typehead = '';
 568         $typehead = '<th>Type</th>' if $withtype;
 569         my $chghead = '';
 570         $chghead = substr(<<EOT, 0, -1) if $withchanged;
 571 <th><span class="hover">Changed<span><span class="head">Changed</span
 572 />The last time a ref change was received by this site.</span></span></th
 573 ><th><span class="hover">Idle<span><span class="head">Idle</span
 574 />The most recent committer time in <i>refs/heads</i>.</span></span></th
 575 >
 576 EOT
 577         my $html = <<EOT;
 578 <table class='projectlist'><tr><th>Project</th>$sizehead$typehead$chghead<th class="desc">Description</th></tr>
 579 EOT
 580         my $trclass = ' class="odd"';
 581         foreach (sort({lc($a) cmp lc($b)} @_)) {
 582                 if (Girocco::Project::does_exist($_, 1)) {
 583                         my $proj = Girocco::Project->load($_);
 584                         my $projname = $proj->{name}.".git";
 585                         my $projdesc = $proj->{desc}||'';
 586                         utf8::decode($projdesc) if utf8::valid($projdesc);
 587                         my $sizecol = '';
 588                         if ($withsize) {
 589                                 my $psize = $proj->{reposizek};
 590                                 $psize = undef unless defined($psize) && $psize =~ /^\d+$/;
 591                                 $psize = 0 if !defined($psize) && $proj->is_empty;
 592                                 if (!defined($psize)) {
 593                                         $psize = 'unknown';
 594                                 } elsif (!$psize) {
 595                                         $psize = 'empty';
 596                                 } else {
 597                                         $psize = human_size($psize * 1024);
 598                                         $psize =~ s/ /\&#160;/g;
 599                                 }
 600                                 $sizecol = '<td class="sizecol">'.$psize.'</td>';
 601                         }
 602                         my $typecol = '';
 603                         if ($withtype) {
 604                                 if ($proj->{mirror}) {
 605                                         $typecol = substr(<<EOT, 0, -1);
 606 <td class="type"><span class="hover">mirror<span class="nowrap">@{[_escapeHTML($proj->{url})]}</span></span></td>
 607 EOT
 608                                 } else {
 609                                         my $users = @{$proj->{users}};
 610                                         $users .= ' user';
 611                                         $users .= 's' unless @{$proj->{users}} == 1;
 612                                         my $userlist = join(', ', sort({lc($a) cmp lc($b)} @{$proj->{users}}));
 613                                         my $spncls = length($userlist) > 25 ? '' : ' class="nowrap"';
 614                                         $typecol = $userlist ? substr(<<EOT, 0, -1) : substr(<<EOT, 0, -1);
 615 <td class="type"><span class="hover">$users<span$spncls>$userlist</span></span></td>
 616 EOT
 617 <td class="type">$users</td>
 618 EOT
 619                                 }
 620                         }
 621                         my $changecol = '';
 622                         if ($withchanged) {
 623                                 my $rel = '';
 624                                 my $changetime = $proj->{lastchange};
 625                                 if ($changetime) {
 626                                         $rel = "<span class=\"hover\">" .
 627                                                 _rel_age(time - parse_rfc2822_date($changetime)) .
 628                                                 "<span class=\"nowrap\">$changetime</span></span>";
 629                                 } else {
 630                                         $rel = "no commits";
 631                                 }
 632                                 $changecol = substr(<<EOT, 0, -1);
 633 <td class="change">$rel</td>
 634 EOT
 635                                 my $idletime = $proj->{lastactivity};
 636                                 my ($idlesecs, $tz);
 637                                 $idlesecs = parse_any_date($idletime, \$tz) if $idletime;
 638                                 if ($idlesecs) {
 639                                         my $idle2822 = _strftime("%a, %d %b %Y %T %z", $idlesecs, $tz);
 640                                         $rel = "<span class=\"hover\">" .
 641                                                 _rel_idle(time - $idlesecs) .
 642                                                 "<span class=\"nowrap\">$idle2822</span></span>";
 643                                 } else {
 644                                         $rel = "no commits";
 645                                 }
 646                                 $changecol .= substr(<<EOT, 0, -1);
 647 <td class="idle">$rel</td>
 648 EOT
 649                         }
 650                         $html .= <<EOT;
 651 <tr$trclass><td><a href="@{[url_path($Girocco::Config::gitweburl)]}/$projname"$target
 652 >@{[_escapeHTML($projname)]}</td>$sizecol$typecol$changecol<td>@{[_escapeHTML($projdesc)]}</td></tr>
 653 EOT
 654                         $trclass = $trclass ? '' : ' class="odd"';
 655                         ++$count;
 656                 }
 657         }
 658         $html .= <<EOT;
 659 </table>
 660 EOT
 661         return ($count || (defined($options->{emptyok}) && $options->{emptyok})) ? $html : '';
 662 }
 663
 664 my %_month_names;
 665 BEGIN {
 666         %_month_names = (
 667                 jan => 0, feb => 1, mar => 2, apr => 3, may => 4, jun => 5,
 668                 jul => 6, aug => 7, sep => 8, oct => 9, nov => 10, dec => 11
 669         );
 670 }
 671
 672 # Should be in "date '+%a, %d %b %Y %T %z'" format as saved to lastgc, lastrefresh and lastchange
 673 # The leading "%a, " is optional, returns undef if unrecognized date.  This is also known as
 674 # RFC 2822 date format and git's '%cD', '%aD' and --date=rfc2822 format.
 675 # If the second argument is a SCALAR ref, its value will be set to the TZ offset in seconds
 676 sub parse_rfc2822_date {
 677         my $dstr = shift || '';
 678         my $tzoff = shift || '';
 679         $dstr = $1 if $dstr =~/^[^\s]+,\s*(.*)$/;
 680         return undef unless $dstr =~
 681                 /^\s*(\d{1,2})\s+([A-Za-z]{3})\s+(\d{4})\s+(\d{1,2}):(\d{2}):(\d{2})\s+([+-]\d{4})\s*$/;
 682         my ($d,$b,$Y,$H,$M,$S,$z) = ($1,$2,$3,$4,$5,$6,$7);
 683         my $m = $_month_names{lc($b)};
 684         return undef unless defined($m);
 685         my $seconds = timegm(0+$S, 0+$M, 0+$H, 0+$d, 0+$m, $Y-1900);
 686         my $offset = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
 687         $offset = -$offset if substr($z,0,1) eq '-';
 688         $$tzoff = $offset if ref($tzoff) eq 'SCALAR';
 689         return $seconds - $offset;
 690 }
 691
 692 # Will parse any supported date format.  Actually there are three formats
 693 # currently supported:
 694 #   1. RFC 2822 (uses parse_rfc2822_date)
 695 #   2. RFC 3339 / ISO 8601 (T may be ' ' or '_', 'Z' is optional or may be 'UTC', ':' optional in TZ)
 696 #   3. Same as #2 except no colons or hyphens allowed and hours MUST be 2 digits
 697 #   4. unix seconds since epoch with optional +/- trailing TZ (may not have a ':')
 698 # Returns undef if unsupported date.
 699 # If the second argument is a SCALAR ref, its value will be set to the TZ offset in seconds
 700 sub parse_any_date {
 701         my $dstr = shift || '';
 702         my $tzoff = shift || '';
 703         if ($dstr =~ /^\s*([-+]?\d+)(?:\s+([-+]\d{4}))?\s*$/) {
 704                 # Unix timestamp
 705                 my $ts = 0 + $1;
 706                 my $off = 0;
 707                 if ($2) {
 708                         my $z = $2;
 709                         $off = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
 710                         $off = -$off if substr($z,0,1) eq '-';
 711                 }
 712                 $$tzoff = $off if ref($tzoff) eq 'SCALAR';
 713                 return $ts;
 714         }
 715         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*$/ ||
 716             $dstr =~ /^\s*(\d{4})(\d{2})(\d{2})[Tt _](\d{2})(\d{2})(\d{2})(?:[ _]?([Zz]|[Uu][Tt][Cc]|(?:[-+]\d{2}\d{2})))?\s*$/) {
 717                 my ($Y,$m,$d,$H,$M,$S,$z) = ($1,$2,$3,$4,$5,$6,$7||'');
 718                 my $seconds = timegm(0+$S, 0+$M, 0+$H, 0+$d, $m-1, $Y-1900);
 719                 defined($z) && $z ne '' or $z = 'Z';
 720                 $z = uc($z);
 721                 $z =~ s/://;
 722                 substr($z,1,0) = '0' if length($z) == 4;
 723                 my $off = 0;
 724                 if ($z ne 'Z' && $z ne 'UTC') {
 725                         $off = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
 726                         $off = -$off if substr($z,0,1) eq '-';
 727                 }
 728                 $$tzoff = $off if ref($tzoff) eq 'SCALAR';
 729                 return $seconds - $off;
 730         }
 731         return parse_rfc2822_date($dstr, $tzoff);
 732 }
 733
 734 # Input is a number such as a minute interval
 735 # Return value is a random number between the input and 1.25*input
 736 # This can be used to randomize the update and gc operations a bit to avoid
 737 # having them all end up all clustered together
 738 sub rand_adjust {
 739         my $input = shift || 0;
 740         return $input unless $input;
 741         return $input + int(rand(0.25 * $input));
 742 }
 743
 744 # Open a pipe to a new sendmail process.  The '-i' option is always passed to
 745 # the new process followed by any addtional arguments passed in.  Note that
 746 # the sendmail process is only expected to understand the '-i', '-t' and '-f'
 747 # options.  Using any other options via this function is not guaranteed to work.
 748 # A list of recipients may follow the options.  Combining a list of recipients
 749 # with the '-t' option is not recommended.
 750 sub sendmail_pipe {
 751         return undef unless @_;
 752         die "\$Girocco::Config::sendmail_bin is unset or not executable!\n"
 753                 unless $Girocco::Config::sendmail_bin && -x $Girocco::Config::sendmail_bin;
 754         my $result = open(my $pipe, '|-', $Girocco::Config::sendmail_bin, '-i', @_);
 755         return $result ? $pipe : undef;
 756 }
 757
 758 # Open a pipe that works similarly to a mailer such as /usr/bin/mail in that
 759 # if the first argument is '-s', a subject line will be automatically added
 760 # (using the second argument as the subject).  Any remaining arguments are
 761 # expected to be recipient addresses that will be added to an explicit To:
 762 # line as well as passed on to sendmail_pipe.  In addition an
 763 # "Auto-Submitted: auto-generated" header is always added as well as a suitable
 764 # "From:" header.
 765 sub mailer_pipe {
 766         my $subject = undef;
 767         if (@_ >= 2 && $_[0] eq '-s') {
 768                 shift;
 769                 $subject = shift;
 770         }
 771         my $tolist = join(", ", @_);
 772         unshift(@_, '-f', $Girocco::Config::sender) if $Girocco::Config::sender;
 773         my $pipe = sendmail_pipe(@_);
 774         if ($pipe) {
 775                 print $pipe "From: \"$Girocco::Config::name\" ",
 776                         "($Girocco::Config::title) ",
 777                         "<$Girocco::Config::admin>\n";
 778                 print $pipe "To: $tolist\n";
 779                 print $pipe "Subject: $subject\n" if defined($subject);
 780                 print $pipe "MIME-Version: 1.0\n";
 781                 print $pipe "Content-Type: text/plain; charset=utf-8\n";
 782                 print $pipe "Content-Transfer-Encoding: 8bit\n";
 783                 print $pipe "X-Girocco: $Girocco::Config::gitweburl\n"
 784                         unless $Girocco::Config::suppress_x_girocco;
 785                 print $pipe "Auto-Submitted: auto-generated\n";
 786                 print $pipe "\n";
 787         }
 788         return $pipe;
 789 }
 790
 791 sub _goodval {
 792         my $val = shift;
 793         return undef unless defined($val);
 794         $val =~ s/[\r\n]+$//s;
 795         return undef unless $val =~ /^\d+$/;
 796         $val = 0 + $val;
 797         return undef unless $val >= 1;
 798         return $val;
 799 }
 800
 801 # Returns the number of "online" cpus or undef if undetermined
 802 sub online_cpus {
 803         my @confcpus = $^O eq "linux" ?
 804                 qw(_NPROCESSORS_ONLN NPROCESSORS_ONLN) :
 805                 qw(NPROCESSORS_ONLN _NPROCESSORS_ONLN) ;
 806         my $cpus = _goodval(get_cmd('getconf', $confcpus[0]));
 807         return $cpus if $cpus;
 808         $cpus = _goodval(get_cmd('getconf', $confcpus[1]));
 809         return $cpus if $cpus;
 810         if ($^O ne "linux") {
 811                 my @sysctls = qw(hw.ncpu);
 812                 unshift(@sysctls, qw(hw.availcpu)) if $^O eq "darwin";
 813                 foreach my $mib (@sysctls) {
 814                         $cpus = _goodval(get_cmd('sysctl', '-n', $mib));
 815                         return $cpus if $cpus;
 816                 }
 817         }
 818         return undef;
 819 }
 820
 821 # Returns the system page size in bytes or undef if undetermined
 822 # This should never fail on a POSIX system
 823 sub sys_pagesize {
 824         use POSIX ":unistd_h";
 825         my $pagesize = sysconf(_SC_PAGESIZE);
 826         return undef unless defined($pagesize) && $pagesize =~ /^\d+$/;
 827         $pagesize = 0 + $pagesize;
 828         return undef unless $pagesize >= 256;
 829         return $pagesize;
 830 }
 831
 832 # Returns the amount of available physical memory in bytes
 833 # This may differ from the actual amount of physical memory installed
 834 # Returns undef if this cannot be determined
 835 sub sys_memsize {
 836         my $pagesize = sys_pagesize;
 837         if ($pagesize && $^O eq "linux") {
 838                 my $pages = _goodval(get_cmd('getconf', '_PHYS_PAGES'));
 839                 return $pagesize * $pages if $pages;
 840         }
 841         if ($^O ne "linux") {
 842                 my @sysctls = qw(hw.physmem64);
 843                 unshift(@sysctls, qw(hw.memsize)) if $^O eq "darwin";
 844                 foreach my $mib (@sysctls) {
 845                         my $memsize = _goodval(get_cmd('sysctl', '-n', $mib));
 846                         return $memsize if $memsize;
 847                 }
 848                 my $memsize32 = _goodval(get_cmd('sysctl', '-n', 'hw.physmem'));
 849                 return $memsize32 if $memsize32 && $memsize32 <= 2147483647;
 850                 if ($pagesize) {
 851                         my $pages = _goodval(get_cmd('sysctl', '-n', 'hw.availpages'));
 852                         return $pagesize * $pages if $pages;
 853                 }
 854                 return 2147483647 + 1 if $memsize32;
 855         }
 856         return undef;
 857 }
 858
 859 sub _get_max_conf_suffixed_size {
 860         my $conf = shift;
 861         return undef unless defined $conf && $conf =~ /^(\d+)([kKmMgG]?)$/;
 862         my ($val, $suffix) = (0+$1, lc($2));
 863         $val *= 1024 if $suffix eq 'k';
 864         $val *= 1024 * 1024 if $suffix eq 'm';
 865         $val *= 1024 * 1024 * 1024 if $suffix eq 'g';
 866         return $val;
 867 }
 868
 869 sub _make_suffixed_size {
 870         my $size = shift;
 871         return $size if $size % 1024;
 872         $size /= 1024;
 873         return "${size}k" if $size % 1024;
 874         $size /= 1024;
 875         return "${size}m" if $size % 1024;
 876         $size /= 1024;
 877         return "${size}g";
 878 }
 879
 880 # Return the value to pass to --window-memory= for git repack
 881 # If the system memory or number of CPUs cannot be determined, returns "1g"
 882 # Otherwise returns one third the available memory divided by the number of CPUs
 883 # but never more than 1 gigabyte or max_gc_window_memory_size.
 884 sub calc_windowmemory {
 885         my $cpus = online_cpus;
 886         my $memsize = sys_memsize;
 887         my $max = 1024 * 1024 * 1024;
 888         if ($cpus && $memsize) {
 889                 $max = int($memsize / 3 / $cpus);
 890                 $max = 1024 * 1024 * 1024 if $max >= 1024 * 1024 * 1024;
 891         }
 892         my $maxconf = _get_max_conf_suffixed_size($Girocco::Config::max_gc_window_memory_size);
 893         $max = $maxconf if defined($maxconf) && $maxconf && $max > $maxconf;
 894         return _make_suffixed_size($max);
 895 }
 896
 897 # Return the value to set as core.bigFileThreshold for git repack
 898 # If the system memory cannot be determined, returns "256m"
 899 # Otherwise returns the available memory divided by 16
 900 # but never more than 512 megabytes or max_gc_big_file_threshold_size.
 901 sub calc_bigfilethreshold {
 902         my $memsize = sys_memsize;
 903         my $max = 256 * 1024 * 1024;
 904         if ($memsize) {
 905                 $max = int($memsize / 16);
 906                 $max = 512 * 1024 * 1024 if $max >= 512 * 1024 * 1024;
 907         }
 908         my $maxconf = _get_max_conf_suffixed_size($Girocco::Config::max_gc_big_file_threshold_size);
 909         $max = $maxconf if defined($maxconf) && $maxconf && $max > $maxconf;
 910         return _make_suffixed_size($max);
 911 }
 912
 913 # Return the value to use when deciding whether or not to re-calculate object deltas
 914 # If there are no more than this many objects then deltas will be recomputed in
 915 # order to create more efficient pack files.  The new_delta_threshold value
 916 # is constrained to be at least 1000 * cpu cores and no more than 100000.
 917 # The default is sys_memsize rounded up to the nearest multiple of 256 MB and
 918 # then 5000 per 256 MB or 50000 if we cannot determine memory size but never
 919 # more than 100000 or less than 1000 * cpu cores.
 920 sub calc_redeltathreshold {
 921         my $cpus = online_cpus || 1;
 922         if (defined($Girocco::Config::new_delta_threshold) &&
 923             $Girocco::Config::new_delta_threshold =~ /^\d+/) {
 924                 my $ndt = 0 + $Girocco::Config::new_delta_threshold;
 925                 if ($ndt >= $cpus * 1000) {
 926                         return $ndt <= 100000 ? $ndt : 100000;
 927                 }
 928         }
 929         my $calcval = 50000;
 930         my $memsize = sys_memsize;
 931         if ($memsize) {
 932                 my $quantum = 256 * 1024 * 1024;
 933                 $calcval = 5000 * int(($memsize + ($quantum - 1)) / $quantum);
 934                 $calcval = 1000 * $cpus if $calcval < 1000 * $cpus;
 935                 $calcval = 100000 if $calcval > 100000;
 936         }
 937         return $calcval;
 938 }
 939
 940 # $1 => thing to test
 941 # $2 => optional directory, if given and -e "$2/$1$3", then return false
 942 # $3 => optional, defaults to ''
 943 sub has_reserved_suffix {
 944         no warnings; # avoid silly 'unsuccessful stat on filename with \n' warning
 945         my ($name, $dir, $ext) = @_;
 946         $ext = '' unless defined $ext;
 947         return 0 unless defined $name && $name =~ /\.([^.]+)$/;
 948         return 0 unless exists $Girocco::Config::reserved_suffixes{lc($1)};
 949         return 0 if defined $dir && -e "$dir/$name$ext";
 950         return 1;
 951 }
 952
 953 # undoes effect of `use CGI::Carp qw(fatalsToBrowser);`
 954 # undoes effect of `use CGI::Carp qw(warningsToBrowser);`
 955 sub noFatalsToBrowser {
 956         use Carp qw();
 957         delete $SIG{__DIE__};
 958         delete $SIG{__WARN__};
 959         undef *CORE::GLOBAL::die;
 960         *CORE::GLOBAL::die = sub {Carp::croak(@_)};
 961         undef *CORE::GLOBAL::warn;
 962         *CORE::GLOBAL::warn = sub {Carp::carp(@_)};
 963 }
 964
 965 1;