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