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