Girocco/Util.pm

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