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