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