12 use base
qw(Exporter);
13 our @EXPORT = qw(get_git scrypt jailed_file sendmail_pipe mailer_pipe
14 lock_file unlock_file valid_tag rand_adjust
15 filedb_atomic_append filedb_atomic_edit filedb_grep
16 filedb_atomic_grep valid_email valid_email_multi
17 valid_repo_url valid_web_url url_base url_path url_server
18 projects_html_list parse_rfc2822_date parse_any_date
19 extract_url_hostname is_dns_hostname is_our_hostname
20 get_cmd online_cpus sys_pagesize sys_memsize
21 calc_windowmemory to_utf8 capture_command human_size
22 calc_bigfilethreshold has_reserved_suffix
23 noFatalsToBrowser calc_redeltathreshold);
28 $encoder = Encode
::find_encoding
('Windows-1252') ||
29 Encode
::find_encoding
('ISO-8859-1') or
30 die "failed to load ISO-8859-1 encoder\n";
34 my ($str, $encode) = @_;
35 return undef unless defined $str;
37 if (Encode
::is_utf8
($str) || utf8
::decode
($str)) {
40 $ans = $encoder->decode($str, Encode
::FB_DEFAULT
);
42 utf8
::encode
($ans) if $encode;
46 BEGIN {require "Girocco/extra/capture_command.pl"}
48 # Return the entire output sent to stdout from running a command
49 # Any output the command sends to stderr is discarded
50 # Returns undef if there was an error running the command (see $!)
52 my ($status, $result) = capture_command
(1, undef, @_);
53 return defined($status) && $status == 0 ?
$result : undef;
56 # Same as get_cmd except configured git binary is automatically provided
57 # as the first argument to get_cmd
59 return get_cmd
($Girocco::Config
::git_bin
, @_);
64 crypt($pwd||'', join ('', ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]));
70 $Girocco::Config
::chroot."/$filename";
79 use Fcntl
qw(O_WRONLY O_CREAT O_EXCL);
81 my $handle = new IO
::Handle
;
83 unless (sysopen($handle, $path, O_WRONLY
|O_CREAT
|O_EXCL
)) {
85 while (not sysopen($handle, $path, O_WRONLY
|O_CREAT
|O_EXCL
)) {
86 ($! == EEXIST
) or die "$path open failed: $!";
87 ($cnt++ < 16) or die "$path open failed: cannot open lockfile";
91 # XXX: filedb-specific
92 chmod 0664, $path or die "$path g+w failed: $!";
98 return defined($_[0]) && $_[0] eq jailed_file
('/etc/passwd');
101 sub _run_update_pwd_db
{
102 my ($path, $updatearg) = @_;
103 my @cmd = ($Girocco::Config
::basedir
.'/bin/update-pwd-db', "$path");
104 push(@cmd, $updatearg) if $updatearg;
105 system(@cmd) == 0 or die "update-pwd-db failed: $?";
109 my ($path, $noreplace, $updatearg) = @_;
112 _run_update_pwd_db
("$path.lock", $updatearg)
113 if $Girocco::Config
::update_pwd_db
&& _is_passwd_file
($path);
114 rename "$path.lock", $path or die "$path unlock failed: $!";
116 unlink "$path.lock" or die "$path unlock failed: $!";
120 sub filedb_atomic_append
{
121 my ($file, $line, $updatearg) = @_;
124 open my $src, '<', $file or die "$file open for reading failed: $!";
125 my $dst = lock_file
($file);
128 my $aid = (split /:/)[2];
129 $id = $aid + 1 if ($aid >= $id);
131 print $dst $_ or die "$file(l) write failed: $!";
134 $line =~ s/\\i/$id/g;
135 print $dst "$line\n" or die "$file(l) write failed: $!";
137 close $dst or die "$file(l) close failed: $!";
140 unlock_file
($file, 0, $updatearg);
145 sub filedb_atomic_edit
{
146 my ($file, $fn, $updatearg) = @_;
148 open my $src, '<', $file or die "$file open for reading failed: $!";
149 my $dst = lock_file
($file);
152 print $dst $fn->($_) or die "$file(l) write failed: $!";
155 close $dst or die "$file(l) close failed: $!";
158 unlock_file
($file, 0, $updatearg);
161 sub filedb_atomic_grep
{
162 my ($file, $fn) = @_;
165 open my $src, '<', $file or die "$file open for reading failed: $!";
166 my $dst = lock_file
($file);
169 my $result = $fn->($_);
170 push(@results, $result) if $result;
173 close $dst or die "$file(l) close failed: $!";
176 unlock_file
($file, 1);
181 my ($file, $fn) = @_;
184 open my $src, '<', $file or die "$file open for reading failed: $!";
187 my $result = $fn->($_);
188 push(@results, $result) if $result;
198 defined($email) or $email = '';
199 return $email =~ /^[a-zA-Z0-9+._-]+@[a-zA-Z0-9.-]+$/;
202 sub valid_email_multi
{
203 my $email_multi = shift;
204 defined($email_multi) or $email_multi = '';
205 # More relaxed, we just want to avoid too dangerous characters.
206 return $email_multi =~ /^[a-zA-Z0-9+._, \@-]+$/;
211 defined($url) or $url = '';
213 /^https?:\/\
/[a-zA-Z0-9.:-]+(\/[_\
%a-zA
-Z0
-9.\
/~:?&=;-]*)?(#[a-zA-Z0-9._-]+)?$/;
217 my $url = shift || '';
218 # Currently neither username nor password is allowed in the URL and IPv6
219 # literal addresses are not accepted either.
220 $Girocco::Config
::mirror_svn
&&
221 $url =~ /^svn(\+https?)?:\/\
/[a-zA-Z0-9.:-]+(\/[_\
%a-zA
-Z0
-9.\
/~-]*)?$/os
223 $Girocco::Config
::mirror_darcs
&&
224 $url =~ /^darcs:\/\
/[a-zA-Z0-9.:-]+(\/[_\
%a-zA
-Z0
-9.\
/~-]*)?$/os
226 $Girocco::Config
::mirror_bzr
&&
227 $url =~ /^bzr:\/\
/[a-zA-Z0-9.:-]+(\/[_\
%a-zA
-Z0
-9.\
/~-]*)?$/os
229 $Girocco::Config
::mirror_hg
&&
230 $url =~ /^hg\+https?:\/\
/[a-zA-Z0-9.:-]+(\/[_\
%a-zA
-Z0
-9.\
/~-]*)?$/os
232 return $url =~ /^(https?|git):\/\
/[a-zA-Z0-9.:-]+(\/[_\
%a-zA
-Z0
-9.\
/~-]*)?$/;
235 sub extract_url_hostname
{
236 my $url = shift || '';
237 if ($url =~ m
,^bzr
://,) {
239 return 'launchpad.net' if $url =~ /^lp:/;
241 return undef unless $url =~ m
,^[A
-Za
-z0
-9+.-]+://[^/],;
242 $url =~ s
,^[A
-Za
-z0
-9+.-]+://,,;
243 $url =~ s
,^([^/]+).*$,$1,;
244 $url =~ s/:[0-9]*$//;
245 $url =~ s/^[^\@]*[\@]//;
246 return $url ?
$url : undef;
250 # RFC 1034 section 3.5
251 # RFC 1123 section 2.1
252 # RFC 1738 section 3.1
253 # RFC 2606 sections 2 & 3
254 # RFC 3986 section 3.2.2
255 sub is_dns_hostname
{
257 defined($host) or $host = '';
258 return 0 if $host eq '' || $host =~ /\s/;
259 # first remove a trailing '.'
261 return 0 if length($host) > 255;
262 my $octet = '(?:\d|[1-9]\d|1\d{2}|2[0-4]\d|25[0-5])';
263 return 0 if $host =~ /^$octet\.$octet\.$octet\.$octet$/o;
264 my @labels = split(/[.]/, $host, -1);
265 return 0 unless @labels && @labels >= $Girocco::Config
::min_dns_labels
;
266 # now check each label
267 foreach my $label (@labels) {
268 return 0 unless length($label) > 0 && length($label) <= 63;
269 return 0 unless $label =~ /^[A-Za-z0-9](?:[A-Za-z0-9-]*[A-Za-z0-9])?$/;
271 # disallow RFC 2606 names provided at least two labels are present
273 my $tld = lc($labels[-1]);
279 my $sld = lc($labels[-2]);
280 return 0 if $sld eq 'example' &&
281 ($tld eq 'com' || $tld eq 'net' || $tld eq 'org');
286 sub is_our_hostname
{
287 my $test = shift || '';
291 $Girocco::Config
::gitweburl
,
292 $Girocco::Config
::gitwebfiles
,
293 $Girocco::Config
::webadmurl
,
294 $Girocco::Config
::bundlesurl
,
295 $Girocco::Config
::htmlurl
,
296 $Girocco::Config
::httppullurl
,
297 $Girocco::Config
::httpbundleurl
,
298 $Girocco::Config
::httpspushurl
,
299 $Girocco::Config
::gitpullurl
,
300 $Girocco::Config
::pushurl
302 foreach my $url (@urls) {
304 my $host = extract_url_hostname
($url);
305 if (defined($host)) {
307 $names{lc($host)} = 1;
311 return $names{lc($test)} ?
1 : 0;
314 my (%_oktags, %_badtags);
316 # entries MUST be all lowercase to be effective
318 # These are always okay (a "whitelist") even if they would otherwise
320 ".net"=>1, "2d"=>1, "3d"=>1, "6502"=>1, "68000"=>1, "68008"=>1,
321 "68010"=>1, "68020"=>1, "68030"=>1, "68040"=>1, "68060"=>1,
322 "8086"=>1, "80286"=>1, "80386"=>1, "80486"=>1, "80586"=>1,
323 c
=>1, cc
=>1, make
=>1, www
=>1, x
=>1
325 map({$_oktags{lc($_)}=1} @Girocco::Config
::allowed_tags
);
326 # entries MUST be all lowercase to be effective
328 # These are "nonsense" or pointless tags
329 about
=>1, after
=>1, all
=>1, also
=>1, an
=>1, and=>1, another
=>1, any
=>1,
330 are
=>1, as
=>1, at
=>1, be
=>1, because
=>1, been
=>1, before
=>1, being
=>1,
331 between
=>1, both
=>1, but
=>1, by
=>1, came
=>1, can
=>1, come
=>1, could
=>1,
332 did
=>1, do=>1, each=>1, for=>1, from
=>1, get
=>1, got
=>1, had
=>1, has
=>1,
333 have
=>1, he
=>1, her
=>1, here
=>1, him
=>1, himself
=>1, his
=>1, how
=>1,
334 if=>1, in=>1, into
=>1, is
=>1, it
=>1, like
=>1, make
=>1, many
=>1, me
=>1,
335 might
=>1, more
=>1, most
=>1, much
=>1, must
=>1, my=>1, never
=>1, now
=>1,
336 of
=>1, oh
=>1, on
=>1, only
=>1, or=>1, other
=>1, our=>1, out
=>1, over
=>1,
337 said
=>1, same
=>1, see
=>1, should
=>1, since
=>1, some
=>1, still
=>1,
338 such
=>1, take
=>1, than
=>1, that
=>1, the
=>1, their
=>1, them
=>1, then
=>1,
339 there
=>1, these
=>1, they
=>1, this
=>1, those
=>1, through
=>1, to
=>1,
340 too
=>1, under
=>1, up
=>1, very
=>1, was
=>1, way
=>1, we
=>1, well
=>1,
341 were
=>1, what
=>1, where
=>1, which
=>1, while=>1, who
=>1, with
=>1,
342 would
=>1, yea
=>1, yeah
=>1, you
=>1, your
=>1, yup
=>1
344 # These are "offensive" tags with at least one letter escaped to
345 # avoid having this file trigger various safe-scan robots
346 $_badtags{"a\x73\x73"} = 1;
347 $_badtags{"a\x73\x73hole"} = 1;
348 $_badtags{"b\x30\x30b"} = 1;
349 $_badtags{"b\x30\x30bs"} = 1;
350 $_badtags{"b\x6f\x6fb"} = 1;
351 $_badtags{"b\x6f\x6fbs"} = 1;
352 $_badtags{"b\x75tt"} = 1;
353 $_badtags{"b\x75ttd\x69\x63k"} = 1;
354 $_badtags{"c\x6f\x63k"} = 1;
355 $_badtags{"c\x75\x6e\x74"} = 1;
356 $_badtags{"d\x69\x63k"} = 1;
357 $_badtags{"d\x69\x63kb\x75tt"} = 1;
358 $_badtags{"f\x75\x63k"} = 1;
359 $_badtags{"in\x63\x65st"} = 1;
360 $_badtags{"ph\x75\x63k"} = 1;
361 $_badtags{"p\x6f\x72n"} = 1;
362 $_badtags{"p\x6f\x72no"} = 1;
363 $_badtags{"p\x6f\x72nographic"} = 1;
364 $_badtags{"p\x72\x30n"} = 1;
365 $_badtags{"p\x72\x6fn"} = 1;
366 $_badtags{"r\x61\x70e"} = 1;
367 $_badtags{"s\x65\x78"} = 1;
368 map({$_badtags{lc($_)}=1} @Girocco::Config
::blocked_tags
);
371 # A valid tag must only have [a-zA-Z0-9:.+#_-] characters, must start with a
372 # letter, must not be a noise word, must be more than one character long,
373 # must not be a repeated letter and must be no more than 32 characters long.
374 # However, anything in %_oktags is explicitly allowed even if it otherwise
375 # would violate the rules.
377 local $_ = $_[0] || '';
378 return 1 if $_oktags{lc($_)};
379 return 0 unless /^[a-zA-Z][a-zA-Z0-9:.+#_-]+$/;
380 return 0 if $_badtags{lc($_)};
381 return 0 if /^(.)\1+$/;
382 return length($_) <= 32 ?
1 : 0;
385 # If the passed in argument looks like a URL, return only the stuff up through
386 # the host:port part otherwise return the entire argument.
388 my $url = shift || '';
390 $url = $1.$2.$3.$4 if $url =~ m
,^( [A
-Za
-z
][A
-Za
-z0
-9+.-]*: ) # scheme
391 ( // ) # // separator
392 ((?
:[^\@
]+\@
)?
) # optional userinfo
393 ( [^/?
#]+ ) # host and port
394 (?
:[/?#].*)?$,x; # path and optional query string and/or anchor
398 # If the passed in argument looks like a URL, return only the stuff following
399 # the host:port part otherwise return the entire argument.
400 # If the optional second argument is true, the returned value will have '/'
401 # appended if it does not already end in '/'.
403 my $url = shift || '';
404 my $add_slash = shift || 0;
406 $url = $1 if $url =~ m
,^(?
: [A
-Za
-z
][A
-Za
-z0
-9+.-]*: ) # scheme
407 (?
: // ) # // separator
408 (?
: [^\@
]+\@
)?
# optional userinfo
409 (?
: [^/?
#]+ ) # host and port
410 ((?
:[/?#].*)?)$,x; # path and optional query string and/or anchor
411 $url .= '/' if $add_slash && $url !~ m
|/$|;
415 # If both SERVER_NAME and SERVER_PORT are set pass the argument through url_path
416 # and then prefix it with the appropriate scheme (HTTPS=?on), host and port and
417 # return it. If a something that doesn't look like it could be the start of a
418 # URL path comes back from url_path or SERVER_NAME is a link-local IPv6 address
419 # then just return the argument unchanged.
421 my $url = shift || '';
422 my $path = url_path
($url);
423 return $url unless $path eq '' || $path =~ m
|^[/?
#]|;
424 return $url unless $ENV{'SERVER_NAME'} && $ENV{'SERVER_PORT'} &&
425 $ENV{'SERVER_PORT'} =~ /^[1-9][0-9]{0,4}$/;
426 return $url if $ENV{'SERVER_NAME'} =~ /^[[]?fe80:/i;
427 my $server = $ENV{'SERVER_NAME'};
428 # Deal with Apache bug where IPv6 literal server names do not include
429 # the required surrounding '[' and ']' characters
430 $server = '[' . $server . ']' if $server =~ /:/ && $server !~ /^[[]/;
431 my $ishttps = $ENV{'HTTPS'} && $ENV{'HTTPS'} =~ /^on$/i;
432 my $portnum = 0 + $ENV{'SERVER_PORT'};
434 if (($ishttps && $portnum != 443) || (!$ishttps && $portnum != 80)) {
435 $port = ':' . $portnum;
437 return 'http' . ($ishttps ?
's' : '') . '://' . $server . $port . $path;
440 # Returns the number rounded to the nearest tenths. The ".d" part will be
441 # excluded if it's ".0" unless the optional second argument is true
448 return '' . int($v/10) unless $v % 10 || $use0;
449 return '' . int($v/10) . '.' . ($v%10);
452 # Returns a human-readable size string (e.g. '1.5 MiB') for the value
453 # (in bytes) passed in. Returns '0' for undefined or 0 or not all digits.
454 # Otherwise returns '1 KiB' for < 1024, or else a number rounded to the
455 # nearest tenths of a KiB, MiB or GiB.
458 return "0" unless $v && $v =~ /^\d+$/;
459 return "1 KiB" unless $v > 1024;
461 return _tenths
($v) . " KiB" if $v < 1024;
463 return _tenths
($v) . " MiB" if $v < 1024;
465 return _tenths
($v) . " GiB";
470 $str =~ s/\&/\&/gs;
471 $str =~ s/\</\</gs;
472 $str =~ s/\>/\>/gs;
473 $str =~ s/\"/\"/gs; #"
477 # create relative time string from passed in age in seconds
482 if ($age > 60*60*24*365*2) {
483 $age_str = (int $age/60/60/24/365);
484 $age_str .= " years ago";
485 } elsif ($age > 60*60*24*(365/12)*2) {
486 $age_str = int $age/60/60/24/(365/12);
487 $age_str .= " months ago";
488 } elsif ($age > 60*60*24*7*2) {
489 $age_str = int $age/60/60/24/7;
490 $age_str .= " weeks ago";
491 } elsif ($age > 60*60*24*2) {
492 $age_str = int $age/60/60/24;
493 $age_str .= " days ago";
494 } elsif ($age > 60*60*2) {
495 $age_str = int $age/60/60;
496 $age_str .= " hours ago";
497 } elsif ($age > 60*2) {
498 $age_str = int $age/60;
499 $age_str .= " mins ago";
502 $age_str .= " secs ago";
503 } elsif ($age >= 0) {
504 $age_str = "right now";
506 $age_str = "future time";
511 # create relative time string from passed in idle in seconds
513 my $idle_str = _rel_age
(shift);
514 $idle_str =~ s/ ago//;
515 $idle_str = "not at all" if $idle_str eq "right now";
520 use POSIX
qw(strftime);
521 my ($fmt, $secs, $zonesecs) = @_;
522 my ($S,$M,$H,$d,$m,$y) = gmtime($secs + $zonesecs);
523 $zonesecs = int($zonesecs / 60);
525 my $ans = strftime
($fmt, $S, $M, $H, $d, $m, $y, -1, -1, -1);
529 $zonesecs = -$zonesecs;
533 $z .= sprintf("%02d%02d", int($zonesecs/60), $zonesecs % 60);
538 # Take a list of project names and produce a nicely formated table that
539 # includes owner links and descriptions. If the list is empty returns ''.
540 # The first argument may be a hash ref that contains options. The following
541 # options are available:
542 # target -- sets the target value of the owner link
543 # emptyok -- if true returns an empty table rather than ''
544 # sizecol -- if true include a human-readable size column
545 # typecol -- if true include type column with hover info
546 # changed -- if true include a changed and idle column
547 sub projects_html_list
{
549 if (defined($_[0]) && ref($_[0]) eq 'HASH') {
552 return '' unless @_ || (defined($options->{emptyok
}) && $options->{emptyok
});
553 require Girocco
::Project
;
556 $target = " target=\""._escapeHTML
($options->{target
})."\""
557 if defined($options->{target
});
558 my $withsize = defined($options->{sizecol
}) && $options->{sizecol
};
559 my $withtype = defined($options->{typecol
}) && $options->{typecol
};
560 my $withchanged = defined($options->{changed
}) && $options->{changed
};
562 $sizehead = substr(<<EOT, 0, -1) if $withsize;
563 <th class="sizecol"><span class="hover">Size<span><span class="head">Size</span
564 />Fork size excludes objects borrowed from the parent.</span></span></th
568 $typehead = '<th>Type</th>' if $withtype;
570 $chghead = substr(<<EOT, 0, -1) if $withchanged;
571 <th><span class="hover">Changed<span><span class="head">Changed</span
572 />The last time a ref change was received by this site.</span></span></th
573 ><th><span class="hover">Idle<span><span class="head">Idle</span
574 />The most recent committer time in <i>refs/heads</i>.</span></span></th
578 <table class='projectlist'><tr><th>Project</th>$sizehead$typehead$chghead<th class="desc">Description</th></tr>
580 my $trclass = ' class="odd"';
581 foreach (sort({lc($a) cmp lc($b)} @_)) {
582 if (Girocco
::Project
::does_exist
($_, 1)) {
583 my $proj = Girocco
::Project
->load($_);
584 my $projname = $proj->{name
}.".git";
585 my $projdesc = $proj->{desc
}||'';
586 utf8
::decode
($projdesc) if utf8
::valid
($projdesc);
589 my $psize = $proj->{reposizek
};
590 $psize = undef unless defined($psize) && $psize =~ /^\d+$/;
591 $psize = 0 if !defined($psize) && $proj->is_empty;
592 if (!defined($psize)) {
597 $psize = human_size
($psize * 1024);
598 $psize =~ s/ /\ /g;
600 $sizecol = '<td class="sizecol">'.$psize.'</td>';
604 if ($proj->{mirror
}) {
605 $typecol = substr(<<EOT, 0, -1);
606 <td class="type"><span class="hover">mirror<span class="nowrap">@{[_escapeHTML($proj->{url})]}</span></span></td>
609 my $users = @
{$proj->{users
}};
611 $users .= 's' unless @
{$proj->{users
}} == 1;
612 my $userlist = join(', ', sort({lc($a) cmp lc($b)} @
{$proj->{users
}}));
613 my $spncls = length($userlist) > 25 ?
'' : ' class="nowrap"';
614 $typecol = $userlist ?
substr(<<EOT, 0, -1) : substr(<<EOT, 0, -1);
615 <td
class="type"><span
class="hover">$users<span
$spncls>$userlist</span></span
></td
>
617 <td
class="type">$users</td
>
624 my $changetime = $proj->{lastchange
};
626 $rel = "<span class=\"hover\">" .
627 _rel_age
(time - parse_rfc2822_date
($changetime)) .
628 "<span class=\"nowrap\">$changetime</span></span>";
632 $changecol = substr(<<EOT, 0, -1);
633 <td class="change">$rel</td>
635 my $idletime = $proj->{lastactivity
};
637 $idlesecs = parse_any_date
($idletime, \
$tz) if $idletime;
639 my $idle2822 = _strftime
("%a, %d %b %Y %T %z", $idlesecs, $tz);
640 $rel = "<span class=\"hover\">" .
641 _rel_idle
(time - $idlesecs) .
642 "<span class=\"nowrap\">$idle2822</span></span>";
646 $changecol .= substr(<<EOT, 0, -1);
647 <td class="idle">$rel</td>
651 <tr$trclass><td><a href="@{[url_path($Girocco::Config::gitweburl)]}/$projname"$target
652 >@{[_escapeHTML($projname)]}</td>$sizecol$typecol$changecol<td>@{[_escapeHTML($projdesc)]}</td></tr>
654 $trclass = $trclass ?
'' : ' class="odd"';
661 return ($count || (defined($options->{emptyok
}) && $options->{emptyok
})) ?
$html : '';
667 jan
=> 0, feb
=> 1, mar
=> 2, apr
=> 3, may
=> 4, jun
=> 5,
668 jul
=> 6, aug
=> 7, sep
=> 8, oct => 9, nov
=> 10, dec
=> 11
672 # Should be in "date '+%a, %d %b %Y %T %z'" format as saved to lastgc, lastrefresh and lastchange
673 # The leading "%a, " is optional, returns undef if unrecognized date. This is also known as
674 # RFC 2822 date format and git's '%cD', '%aD' and --date=rfc2822 format.
675 # If the second argument is a SCALAR ref, its value will be set to the TZ offset in seconds
676 sub parse_rfc2822_date
{
677 my $dstr = shift || '';
678 my $tzoff = shift || '';
679 $dstr = $1 if $dstr =~/^[^\s]+,\s*(.*)$/;
680 return undef unless $dstr =~
681 /^\s*(\d{1,2})\s+([A-Za-z]{3})\s+(\d{4})\s+(\d{1,2}):(\d{2}):(\d{2})\s+([+-]\d{4})\s*$/;
682 my ($d,$b,$Y,$H,$M,$S,$z) = ($1,$2,$3,$4,$5,$6,$7);
683 my $m = $_month_names{lc($b)};
684 return undef unless defined($m);
685 my $seconds = timegm
(0+$S, 0+$M, 0+$H, 0+$d, 0+$m, $Y-1900);
686 my $offset = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
687 $offset = -$offset if substr($z,0,1) eq '-';
688 $$tzoff = $offset if ref($tzoff) eq 'SCALAR';
689 return $seconds - $offset;
692 # Will parse any supported date format. Actually there are three formats
693 # currently supported:
694 # 1. RFC 2822 (uses parse_rfc2822_date)
695 # 2. RFC 3339 / ISO 8601 (T may be ' ' or '_', 'Z' is optional, ':' optional in TZ)
696 # 3. Same as #2 except no colons or hyphens allowed and hours MUST be 2 digits
697 # 4. unix seconds since epoch with optional +/- trailing TZ (may not have a ':')
698 # Returns undef if unsupported date.
699 # If the second argument is a SCALAR ref, its value will be set to the TZ offset in seconds
701 my $dstr = shift || '';
702 my $tzoff = shift || '';
703 if ($dstr =~ /^\s*([-+]?\d+)(?:\s+([-+]\d{4}))?\s*$/) {
709 $off = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
710 $off = -$off if substr($z,0,1) eq '-';
712 $$tzoff = $off if ref($tzoff) eq 'SCALAR';
715 if ($dstr =~ /^\s*(\d{4})-(\d{2})-(\d{2})[Tt _](\d{1,2}):(\d{2}):(\d{2})(?:[ _]?([Zz]|(?:[-+]\d{1,2}:?\d{2})))?\s*$/ ||
716 $dstr =~ /^\s*(\d{4})(\d{2})(\d{2})[Tt _](\d{2})(\d{2})(\d{2})(?:[ _]?([Zz]|(?:[-+]\d{2}\d{2})))?\s*$/) {
717 my ($Y,$m,$d,$H,$M,$S,$z) = ($1,$2,$3,$4,$5,$6,$7||'');
718 my $seconds = timegm
(0+$S, 0+$M, 0+$H, 0+$d, $m-1, $Y-1900);
719 defined($z) && $z ne '' or $z = 'Z';
721 substr($z,1,0) = '0' if length($z) == 4;
724 $off = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
725 $off = -$off if substr($z,0,1) eq '-';
727 $$tzoff = $off if ref($tzoff) eq 'SCALAR';
728 return $seconds - $off;
730 return parse_rfc2822_date
($dstr, $tzoff);
733 # Input is a number such as a minute interval
734 # Return value is a random number between the input and 1.25*input
735 # This can be used to randomize the update and gc operations a bit to avoid
736 # having them all end up all clustered together
738 my $input = shift || 0;
739 return $input unless $input;
740 return $input + int(rand(0.25 * $input));
743 # Open a pipe to a new sendmail process. The '-i' option is always passed to
744 # the new process followed by any addtional arguments passed in. Note that
745 # the sendmail process is only expected to understand the '-i', '-t' and '-f'
746 # options. Using any other options via this function is not guaranteed to work.
747 # A list of recipients may follow the options. Combining a list of recipients
748 # with the '-t' option is not recommended.
750 return undef unless @_;
751 die "\$Girocco::Config::sendmail_bin is unset or not executable!\n"
752 unless $Girocco::Config
::sendmail_bin
&& -x
$Girocco::Config
::sendmail_bin
;
753 my $result = open(my $pipe, '|-', $Girocco::Config
::sendmail_bin
, '-i', @_);
754 return $result ?
$pipe : undef;
757 # Open a pipe that works similarly to a mailer such as /usr/bin/mail in that
758 # if the first argument is '-s', a subject line will be automatically added
759 # (using the second argument as the subject). Any remaining arguments are
760 # expected to be recipient addresses that will be added to an explicit To:
761 # line as well as passed on to sendmail_pipe. In addition an
762 # "Auto-Submitted: auto-generated" header is always added as well as a suitable
766 if (@_ >= 2 && $_[0] eq '-s') {
770 my $tolist = join(", ", @_);
771 unshift(@_, '-f', $Girocco::Config
::sender
) if $Girocco::Config
::sender
;
772 my $pipe = sendmail_pipe
(@_);
774 print $pipe "From: \"$Girocco::Config::name\" ",
775 "($Girocco::Config::title) ",
776 "<$Girocco::Config::admin>\n";
777 print $pipe "To: $tolist\n";
778 print $pipe "Subject: $subject\n" if defined($subject);
779 print $pipe "MIME-Version: 1.0\n";
780 print $pipe "Content-Type: text/plain; charset=utf-8\n";
781 print $pipe "Content-Transfer-Encoding: 8bit\n";
782 print $pipe "X-Girocco: $Girocco::Config::gitweburl\n"
783 unless $Girocco::Config
::suppress_x_girocco
;
784 print $pipe "Auto-Submitted: auto-generated\n";
792 return undef unless defined($val);
793 $val =~ s/[\r\n]+$//s;
794 return undef unless $val =~ /^\d+$/;
796 return undef unless $val >= 1;
800 # Returns the number of "online" cpus or undef if undetermined
802 my @confcpus = $^O
eq "linux" ?
803 qw(_NPROCESSORS_ONLN NPROCESSORS_ONLN) :
804 qw(NPROCESSORS_ONLN _NPROCESSORS_ONLN) ;
805 my $cpus = _goodval
(get_cmd
('getconf', $confcpus[0]));
806 return $cpus if $cpus;
807 $cpus = _goodval
(get_cmd
('getconf', $confcpus[1]));
808 return $cpus if $cpus;
809 if ($^O
ne "linux") {
810 my @sysctls = qw(hw.ncpu);
811 unshift(@sysctls, qw(hw.availcpu)) if $^O
eq "darwin";
812 foreach my $mib (@sysctls) {
813 $cpus = _goodval
(get_cmd
('sysctl', '-n', $mib));
814 return $cpus if $cpus;
820 # Returns the system page size in bytes or undef if undetermined
821 # This should never fail on a POSIX system
823 use POSIX
":unistd_h";
824 my $pagesize = sysconf
(_SC_PAGESIZE
);
825 return undef unless defined($pagesize) && $pagesize =~ /^\d+$/;
826 $pagesize = 0 + $pagesize;
827 return undef unless $pagesize >= 256;
831 # Returns the amount of available physical memory in bytes
832 # This may differ from the actual amount of physical memory installed
833 # Returns undef if this cannot be determined
835 my $pagesize = sys_pagesize
;
836 if ($pagesize && $^O
eq "linux") {
837 my $pages = _goodval
(get_cmd
('getconf', '_PHYS_PAGES'));
838 return $pagesize * $pages if $pages;
840 if ($^O
ne "linux") {
841 my @sysctls = qw(hw.physmem64);
842 unshift(@sysctls, qw(hw.memsize)) if $^O
eq "darwin";
843 foreach my $mib (@sysctls) {
844 my $memsize = _goodval
(get_cmd
('sysctl', '-n', $mib));
845 return $memsize if $memsize;
847 my $memsize32 = _goodval
(get_cmd
('sysctl', '-n', 'hw.physmem'));
848 return $memsize32 if $memsize32 && $memsize32 <= 2147483647;
850 my $pages = _goodval
(get_cmd
('sysctl', '-n', 'hw.availpages'));
851 return $pagesize * $pages if $pages;
853 return 2147483647 + 1 if $memsize32;
858 sub _get_max_conf_suffixed_size
{
860 return undef unless defined $conf && $conf =~ /^(\d+)([kKmMgG]?)$/;
861 my ($val, $suffix) = (0+$1, lc($2));
862 $val *= 1024 if $suffix eq 'k';
863 $val *= 1024 * 1024 if $suffix eq 'm';
864 $val *= 1024 * 1024 * 1024 if $suffix eq 'g';
868 sub _make_suffixed_size
{
870 return $size if $size % 1024;
872 return "${size}k" if $size % 1024;
874 return "${size}m" if $size % 1024;
879 # Return the value to pass to --window-memory= for git repack
880 # If the system memory or number of CPUs cannot be determined, returns "1g"
881 # Otherwise returns half the available memory divided by the number of CPUs
882 # but never more than 1 gigabyte or max_gc_window_memory_size.
883 sub calc_windowmemory
{
884 my $cpus = online_cpus
;
885 my $memsize = sys_memsize
;
886 my $max = 1024 * 1024 * 1024;
887 if ($cpus && $memsize) {
888 $max = int($memsize / 2 / $cpus);
889 $max = 1024 * 1024 * 1024 if $max >= 1024 * 1024 * 1024;
891 my $maxconf = _get_max_conf_suffixed_size
($Girocco::Config
::max_gc_window_memory_size
);
892 $max = $maxconf if defined($maxconf) && $maxconf && $max > $maxconf;
893 return _make_suffixed_size
($max);
896 # Return the value to set as core.bigFileThreshold for git repack
897 # If the system memory cannot be determined, returns "256m"
898 # Otherwise returns the available memory divided by 16
899 # but never more than 512 megabytes or max_gc_big_file_threshold_size.
900 sub calc_bigfilethreshold
{
901 my $memsize = sys_memsize
;
902 my $max = 256 * 1024 * 1024;
904 $max = int($memsize / 16);
905 $max = 512 * 1024 * 1024 if $max >= 512 * 1024 * 1024;
907 my $maxconf = _get_max_conf_suffixed_size
($Girocco::Config
::max_gc_big_file_threshold_size
);
908 $max = $maxconf if defined($maxconf) && $maxconf && $max > $maxconf;
909 return _make_suffixed_size
($max);
912 # Return the value to use when deciding whether or not to re-calculate object deltas
913 # If there are no more than this many objects then deltas will be recomputed in
914 # order to create more efficient pack files. The new_delta_threshold value
915 # is constrained to be at least 1000 * cpu cores and no more than 100000.
916 # The default is sys_memsize rounded up to the nearest multiple of 256 MB and
917 # then 5000 per 256 MB or 50000 if we cannot determine memory size but never
918 # more than 100000 or less than 1000 * cpu cores.
919 sub calc_redeltathreshold
{
920 my $cpus = online_cpus
|| 1;
921 if (defined($Girocco::Config
::new_delta_threshold
) &&
922 $Girocco::Config
::new_delta_threshold
=~ /^\d+/) {
923 my $ndt = 0 + $Girocco::Config
::new_delta_threshold
;
924 if ($ndt >= $cpus * 1000) {
925 return $ndt <= 100000 ?
$ndt : 100000;
929 my $memsize = sys_memsize
;
931 my $quantum = 256 * 1024 * 1024;
932 $calcval = 5000 * int(($memsize + ($quantum - 1)) / $quantum);
933 $calcval = 1000 * $cpus if $calcval < 1000 * $cpus;
934 $calcval = 100000 if $calcval > 100000;
939 # $1 => thing to test
940 # $2 => optional directory, if given and -e "$2/$1$3", then return false
941 # $3 => optional, defaults to ''
942 sub has_reserved_suffix
{
943 no warnings
; # avoid silly 'unsuccessful stat on filename with \n' warning
944 my ($name, $dir, $ext) = @_;
945 $ext = '' unless defined $ext;
946 return 0 unless defined $name && $name =~ /\.([^.]+)$/;
947 return 0 unless exists $Girocco::Config
::reserved_suffixes
{lc($1)};
948 return 0 if defined $dir && -e
"$dir/$name$ext";
952 # undoes effect of `use CGI::Carp qw(fatalsToBrowser);`
953 # undoes effect of `use CGI::Carp qw(warningsToBrowser);`
954 sub noFatalsToBrowser
{
956 delete $SIG{__DIE__
};
957 delete $SIG{__WARN__
};
958 undef *CORE
::GLOBAL
::die;
959 *CORE
::GLOBAL
::die = sub {Carp
::croak
(@_)};
960 undef *CORE
::GLOBAL
::warn;
961 *CORE
::GLOBAL
::warn = sub {Carp
::carp
(@_)};