8 use Girocco
::ConfigUtil
;
10 use Scalar
::Util
qw(looks_like_number);
14 use base
qw(Exporter);
15 our @EXPORT = qw(get_git scrypt jailed_file sendmail_pipe mailer_pipe
16 lock_file unlock_file valid_tag rand_adjust
17 filedb_atomic_append filedb_atomic_edit filedb_grep
18 filedb_atomic_grep valid_email valid_email_multi
19 valid_repo_url valid_web_url url_base url_path url_server
20 projects_html_list parse_rfc2822_date parse_any_date
21 extract_url_hostname is_dns_hostname is_our_hostname
22 get_cmd online_cpus sys_pagesize sys_memsize
23 calc_windowmemory to_utf8 capture_command human_size
24 calc_bigfilethreshold has_reserved_suffix human_duration
25 noFatalsToBrowser calc_redeltathreshold
26 clean_email_multi read_HEAD_symref read_config_file
27 read_config_file_hash is_git_dir git_bool util_path
28 is_shellish read_HEAD_ref git_add_config to_json
29 json_bool from_json ref_indicator);
32 BEGIN {require "Girocco/extra/capture_command.pl"}
34 # Return the entire output sent to stdout from running a command
35 # Any output the command sends to stderr is discarded
36 # Returns undef if there was an error running the command (see $!)
38 my ($status, $result) = capture_command
(1, undef, @_);
39 return defined($status) && $status == 0 ?
$result : undef;
42 # Same as get_cmd except configured git binary is automatically provided
43 # as the first argument to get_cmd
45 return get_cmd
($Girocco::Config
::git_bin
, @_);
50 crypt($pwd||'', join ('', ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]));
56 $Girocco::Config
::chroot."/$filename";
65 use Fcntl
qw(O_WRONLY O_CREAT O_EXCL);
67 my $handle = new IO
::Handle
;
69 unless (sysopen($handle, $path, O_WRONLY
|O_CREAT
|O_EXCL
)) {
71 while (not sysopen($handle, $path, O_WRONLY
|O_CREAT
|O_EXCL
)) {
72 ($! == EEXIST
) or die "$path open failed: $!";
73 ($cnt++ < 16) or die "$path open failed: cannot open lockfile";
77 # XXX: filedb-specific
78 chmod 0664, $path or die "$path g+w failed: $!";
84 return defined($_[0]) && $_[0] eq jailed_file
('/etc/passwd');
87 sub _run_update_pwd_db
{
88 my ($path, $updatearg) = @_;
89 my @cmd = ($Girocco::Config
::basedir
.'/bin/update-pwd-db', "$path");
90 push(@cmd, $updatearg) if $updatearg;
91 system(@cmd) == 0 or die "update-pwd-db failed: $?";
95 my ($path, $noreplace, $updatearg) = @_;
98 _run_update_pwd_db
("$path.lock", $updatearg)
99 if $Girocco::Config
::update_pwd_db
&& _is_passwd_file
($path);
100 rename "$path.lock", $path or die "$path unlock failed: $!";
102 unlink "$path.lock" or die "$path unlock failed: $!";
106 sub filedb_atomic_append
{
107 my ($file, $line, $updatearg) = @_;
110 open my $src, '<', $file or die "$file open for reading failed: $!";
111 my $dst = lock_file
($file);
114 my $aid = (split /:/)[2];
115 $id = $aid + 1 if ($aid >= $id);
117 print $dst $_ or die "$file(l) write failed: $!";
120 $line =~ s/\\i/$id/g;
121 print $dst "$line\n" or die "$file(l) write failed: $!";
123 close $dst or die "$file(l) close failed: $!";
126 unlock_file
($file, 0, $updatearg);
131 sub filedb_atomic_edit
{
132 my ($file, $fn, $updatearg) = @_;
134 open my $src, '<', $file or die "$file open for reading failed: $!";
135 my $dst = lock_file
($file);
138 print $dst $fn->($_) or die "$file(l) write failed: $!";
141 close $dst or die "$file(l) close failed: $!";
144 unlock_file
($file, 0, $updatearg);
147 sub filedb_atomic_grep
{
148 my ($file, $fn) = @_;
151 open my $src, '<', $file or die "$file open for reading failed: $!";
152 my $dst = lock_file
($file);
155 my $result = $fn->($_);
156 push(@results, $result) if $result;
159 close $dst or die "$file(l) close failed: $!";
162 unlock_file
($file, 1);
167 my ($file, $fn) = @_;
170 open my $src, '<', $file or die "$file open for reading failed: $!";
173 my $result = $fn->($_);
174 push(@results, $result) if $result;
184 defined($email) or $email = '';
185 return $email =~ /^[a-zA-Z0-9+._-]+@[a-zA-Z0-9.-]+$/;
188 sub clean_email_multi
{
190 defined($input) or $input = '';
191 $input =~ s/^\s+//; $input =~ s/\s+$//;
194 foreach (split(/\s*,\s*/, $input)) {
196 $seen{lc($_)} = 1, push(@newlist, $_) unless $seen{lc($_)};
198 return join(",", @newlist);
201 sub valid_email_multi
{
202 # each email address must be a valid_email but we silently
203 # ignore extra spaces at the beginning/end and around any comma(s)
204 foreach (split(/,/, clean_email_multi
(shift))) {
205 return 0 unless valid_email
($_);
212 defined($url) or $url = '';
214 /^https?:\/\
/[a-zA-Z0-9.:-]+(\/[_\
%a-zA
-Z0
-9.\
/~:?&=;-]*)?(#[a-zA-Z0-9._-]+)?$/;
218 my $url = shift || '';
219 # Currently neither username nor password is allowed in the URL (except for svn)
220 # and IPv6 literal addresses are not accepted either.
221 $Girocco::Config
::mirror_svn
&&
222 $url =~ /^svn(\+https?)?:\/\
/([^\@\/\s
]+\@
)?
[a
-zA
-Z0
-9.:-]+(\
/[_\%a-zA-Z0-9.\/+~-]*)?
$/os
224 $Girocco::Config
::mirror_darcs
&&
225 $url =~ /^darcs(?:\+https?)?:\/\
/[a-zA-Z0-9.:-]+(\/[_\
%a-zA
-Z0
-9.\
/+~-]*)?$/os
227 $Girocco::Config
::mirror_bzr
&&
228 $url =~ /^bzr:\/\
/[a-zA-Z0-9.:-]+(\/[_\
%a-zA
-Z0
-9.\
/+~-]*)?$/os
230 $Girocco::Config
::mirror_hg
&&
231 $url =~ /^hg\+https?:\/\
/[a-zA-Z0-9.:-]+(\/[_\
%a-zA
-Z0
-9.\
/+~-]*)?$/os
233 return $url =~ /^(https?|git):\/\
/[a-zA-Z0-9.:-]+(\/[_\
%a-zA
-Z0
-9.\
/+~-]*)?$/;
236 sub extract_url_hostname
{
237 my $url = shift || '';
238 if ($url =~ m
,^bzr
://,) {
240 return 'launchpad.net' if $url =~ /^lp:/;
242 return undef unless $url =~ m
,^[A
-Za
-z0
-9+.-]+://[^/],;
243 $url =~ s
,^[A
-Za
-z0
-9+.-]+://,,;
244 $url =~ s
,^([^/]+).*$,$1,;
245 $url =~ s/:[0-9]*$//;
246 $url =~ s/^[^\@]*[\@]//;
247 return $url ?
$url : undef;
251 # RFC 1034 section 3.5
252 # RFC 1123 section 2.1
253 # RFC 1738 section 3.1
254 # RFC 2606 sections 2 & 3
255 # RFC 3986 section 3.2.2
256 sub is_dns_hostname
{
258 defined($host) or $host = '';
259 return 0 if $host eq '' || $host =~ /\s/;
260 # first remove a trailing '.'
262 return 0 if length($host) > 255;
263 my $octet = '(?:\d|[1-9]\d|1\d{2}|2[0-4]\d|25[0-5])';
264 return 0 if $host =~ /^$octet\.$octet\.$octet\.$octet$/o;
265 my @labels = split(/[.]/, $host, -1);
266 return 0 unless @labels && @labels >= $Girocco::Config
::min_dns_labels
;
267 # now check each label
268 foreach my $label (@labels) {
269 return 0 unless length($label) > 0 && length($label) <= 63;
270 return 0 unless $label =~ /^[A-Za-z0-9](?:[A-Za-z0-9-]*[A-Za-z0-9])?$/;
272 # disallow RFC 2606 names provided at least two labels are present
274 my $tld = lc($labels[-1]);
280 my $sld = lc($labels[-2]);
281 return 0 if $sld eq 'example' &&
282 ($tld eq 'com' || $tld eq 'net' || $tld eq 'org');
287 sub is_our_hostname
{
288 my $test = shift || '';
292 $Girocco::Config
::gitweburl
,
293 $Girocco::Config
::gitwebfiles
,
294 $Girocco::Config
::webadmurl
,
295 $Girocco::Config
::bundlesurl
,
296 $Girocco::Config
::htmlurl
,
297 $Girocco::Config
::httppullurl
,
298 $Girocco::Config
::httpbundleurl
,
299 $Girocco::Config
::httpspushurl
,
300 $Girocco::Config
::gitpullurl
,
301 $Girocco::Config
::pushurl
303 foreach my $url (@urls) {
305 my $host = extract_url_hostname
($url);
306 if (defined($host)) {
308 $names{lc($host)} = 1;
312 return $names{lc($test)} ?
1 : 0;
315 my (%_oktags, %_badtags, %_canontags, $_canontagscreated, @_whitetags);
317 # These are always okay (a "whitelist") even if they would
318 # otherwise not be allowed
320 .net 2d 3d 6502 68000 68008 68010 68020 68030 68040 68060
321 8086 80286 80386 80486 80586 c cc make www x
323 map({$_oktags{lc($_)}=1} @_whitetags, @Girocco::Config
::allowed_tags
);
324 # entries MUST be all lowercase to be effective
326 # These are "nonsense" or pointless tags
327 about
=>1, after
=>1, all
=>1, also
=>1, an
=>1, and=>1, another
=>1, any
=>1,
328 are
=>1, as
=>1, at
=>1, be
=>1, because
=>1, been
=>1, before
=>1, being
=>1,
329 between
=>1, both
=>1, but
=>1, by
=>1, came
=>1, can
=>1, come
=>1, could
=>1,
330 did
=>1, do=>1, each=>1, for=>1, from
=>1, get
=>1, got
=>1, had
=>1, has
=>1,
331 have
=>1, he
=>1, her
=>1, here
=>1, him
=>1, himself
=>1, his
=>1, how
=>1,
332 if=>1, in=>1, into
=>1, is
=>1, it
=>1, like
=>1, make
=>1, many
=>1, me
=>1,
333 might
=>1, more
=>1, most
=>1, much
=>1, must
=>1, my=>1, never
=>1, now
=>1,
334 of
=>1, oh
=>1, on
=>1, only
=>1, or=>1, other
=>1, our=>1, out
=>1, over
=>1,
335 said
=>1, same
=>1, see
=>1, should
=>1, since
=>1, some
=>1, still
=>1,
336 such
=>1, take
=>1, than
=>1, that
=>1, the
=>1, their
=>1, them
=>1, then
=>1,
337 there
=>1, these
=>1, they
=>1, this
=>1, those
=>1, through
=>1, to
=>1,
338 too
=>1, under
=>1, up
=>1, very
=>1, was
=>1, way
=>1, we
=>1, well
=>1,
339 were
=>1, what
=>1, where
=>1, which
=>1, while=>1, who
=>1, with
=>1,
340 would
=>1, yea
=>1, yeah
=>1, you
=>1, your
=>1, yup
=>1
342 # These are "offensive" tags with at least one letter escaped to
343 # avoid having this file trigger various safe-scan robots
344 $_badtags{"a\x73\x73"} = 1;
345 $_badtags{"a\x73\x73hole"} = 1;
346 $_badtags{"b\x30\x30b"} = 1;
347 $_badtags{"b\x30\x30bs"} = 1;
348 $_badtags{"b\x6f\x6fb"} = 1;
349 $_badtags{"b\x6f\x6fbs"} = 1;
350 $_badtags{"b\x75tt"} = 1;
351 $_badtags{"b\x75ttd\x69\x63k"} = 1;
352 $_badtags{"c\x6f\x63k"} = 1;
353 $_badtags{"c\x75\x6e\x74"} = 1;
354 $_badtags{"d\x69\x63k"} = 1;
355 $_badtags{"d\x69\x63kb\x75tt"} = 1;
356 $_badtags{"f\x75\x63k"} = 1;
357 $_badtags{"in\x63\x65st"} = 1;
358 $_badtags{"ph\x75\x63k"} = 1;
359 $_badtags{"p\x6f\x72n"} = 1;
360 $_badtags{"p\x6f\x72no"} = 1;
361 $_badtags{"p\x6f\x72nographic"} = 1;
362 $_badtags{"p\x72\x30n"} = 1;
363 $_badtags{"p\x72\x6fn"} = 1;
364 $_badtags{"r\x61\x70e"} = 1;
365 $_badtags{"s\x65\x78"} = 1;
366 map({$_badtags{lc($_)}=1} @Girocco::Config
::blocked_tags
);
369 # A valid tag must only have [a-zA-Z0-9:.+#_-] characters, must start with a
370 # letter, must not be a noise word, must be more than one character long,
371 # must not be a repeated letter and must be no more than 32 characters long.
372 # However, anything in %_oktags is explicitly allowed even if it otherwise
373 # would violate the rules (except that none of [,\s\\\/] are allowed in tags).
374 # Returns the canonical name for the tag if the tag is valid otherwise undef.
377 return undef unless defined($_) && $_ ne "" && !/[,\s\/\\]/;
378 my $fold = $Girocco::Config
::foldtags
;
379 if ($fold && !$_canontagscreated) {
382 $_canontags{lc($_)} = $_ foreach sort({$b cmp $a} @_whitetags, @Girocco::Config
::allowed_tags
);
383 $_canontagscreated = 1;
385 return $_canontags{lc($_)} if $fold && exists($_canontags{lc($_)});
386 return ($fold ?
lc($_) : $_) if $_oktags{lc($_)};
387 return undef unless /^[a-zA-Z][a-zA-Z0-9:.+#_-]+$/;
388 return undef if $_badtags{lc($_)};
389 return undef if /^(.)\1+$/;
390 return length($_) <= 32 ?
($fold ?
lc($_) : $_) : undef;
393 # If the passed in argument looks like a URL, return only the stuff up through
394 # the host:port part otherwise return the entire argument.
396 my $url = shift || '';
398 $url = $1.$2.$3.$4 if $url =~ m
,^( [A
-Za
-z
][A
-Za
-z0
-9+.-]*: ) # scheme
399 ( // ) # // separator
400 ((?
:[^\@
]+\@
)?
) # optional userinfo
401 ( [^/?
#]+ ) # host and port
402 (?
:[/?#].*)?$,x; # path and optional query string and/or anchor
406 # If the passed in argument looks like a URL, return only the stuff following
407 # the host:port part otherwise return the entire argument.
408 # If the optional second argument is true, the returned value will have '/'
409 # appended if it does not already end in '/'.
411 my $url = shift || '';
412 my $add_slash = shift || 0;
414 $url = $1 if $url =~ m
,^(?
: [A
-Za
-z
][A
-Za
-z0
-9+.-]*: ) # scheme
415 (?
: // ) # // separator
416 (?
: [^\@
]+\@
)?
# optional userinfo
417 (?
: [^/?
#]+ ) # host and port
418 ((?
:[/?#].*)?)$,x; # path and optional query string and/or anchor
419 $url .= '/' if $add_slash && $url !~ m
|/$|;
423 # If both SERVER_NAME and SERVER_PORT are set pass the argument through url_path
424 # and then prefix it with the appropriate scheme (HTTPS=?on), host and port and
425 # return it. If a something that doesn't look like it could be the start of a
426 # URL path comes back from url_path or SERVER_NAME is a link-local IPv6 address
427 # then just return the argument unchanged.
429 my $url = shift || '';
430 my $path = url_path
($url);
431 return $url unless $path eq '' || $path =~ m
|^[/?
#]|;
432 return $url unless $ENV{'SERVER_NAME'} && $ENV{'SERVER_PORT'} &&
433 $ENV{'SERVER_PORT'} =~ /^[1-9][0-9]{0,4}$/;
434 return $url if $ENV{'SERVER_NAME'} =~ /^[[]?fe80:/i;
435 my $server = $ENV{'SERVER_NAME'};
436 # Deal with Apache bug where IPv6 literal server names do not include
437 # the required surrounding '[' and ']' characters
438 $server = '[' . $server . ']' if $server =~ /:/ && $server !~ /^[[]/;
439 my $ishttps = $ENV{'HTTPS'} && $ENV{'HTTPS'} =~ /^on$/i;
440 my $portnum = 0 + $ENV{'SERVER_PORT'};
442 if (($ishttps && $portnum != 443) || (!$ishttps && $portnum != 80)) {
443 $port = ':' . $portnum;
445 return 'http' . ($ishttps ?
's' : '') . '://' . $server . $port . $path;
448 # Returns the number rounded to the nearest tenths. The ".d" part will be
449 # excluded if it's ".0" unless the optional second argument is true
456 return '' . int($v/10) unless $v % 10 || $use0;
457 return '' . int($v/10) . '.' . ($v%10);
460 # Returns a human-readable size string (e.g. '1.5 MiB') for the value
461 # (in bytes) passed in. Returns '0' for undefined or 0 or not all digits.
462 # Otherwise returns '1 KiB' for < 1024, or else a number rounded to the
463 # nearest tenths of a KiB, MiB or GiB.
466 return "0" unless $v && $v =~ /^\d+$/;
467 return "1 KiB" unless $v > 1024;
469 return _tenths
($v) . " KiB" if $v < 1024;
471 return _tenths
($v) . " MiB" if $v < 1024;
473 return _tenths
($v) . " GiB";
476 # Returns a human duration string (e.g. 1h10m5s for the value (in secs)
477 # passed in. Returns the value unchanged if it's not defined or <= 0.
480 return $secs unless defined($secs) && $secs >= 0;
482 my $ans = ($secs % 60) . 's';
483 return $ans if $secs < 60;
484 $secs = int($secs / 60);
485 $ans = ($secs % 60) . 'm' . $ans;
486 return $ans if $secs < 60;
487 $secs = int($secs / 60);
488 $ans = ($secs % 24) . 'h' . $ans;
489 return $ans if $secs < 24;
490 $secs = int($secs / 24);
491 return $secs . 'd' . $ans;
496 $str =~ s/\&/\&/gs;
497 $str =~ s/\</\</gs;
498 $str =~ s/\>/\>/gs;
499 $str =~ s/\"/\"/gs; #"
503 # create relative time string from passed in age in seconds
508 if ($age > 60*60*24*365*2) {
509 $age_str = (int $age/60/60/24/365);
510 $age_str .= " years ago";
511 } elsif ($age > 60*60*24*(365/12)*2) {
512 $age_str = int $age/60/60/24/(365/12);
513 $age_str .= " months ago";
514 } elsif ($age > 60*60*24*7*2) {
515 $age_str = int $age/60/60/24/7;
516 $age_str .= " weeks ago";
517 } elsif ($age > 60*60*24*2) {
518 $age_str = int $age/60/60/24;
519 $age_str .= " days ago";
520 } elsif ($age > 60*60*2) {
521 $age_str = int $age/60/60;
522 $age_str .= " hours ago";
523 } elsif ($age > 60*2) {
524 $age_str = int $age/60;
525 $age_str .= " mins ago";
528 $age_str .= " secs ago";
529 } elsif ($age >= 0) {
530 $age_str = "right now";
532 $age_str = "future time";
537 # create relative time string from passed in idle in seconds
539 my $idle_str = _rel_age
(shift);
540 $idle_str =~ s/ ago//;
541 $idle_str = "not at all" if $idle_str eq "right now";
546 use POSIX
qw(strftime);
547 my ($fmt, $secs, $zonesecs) = @_;
548 my ($S,$M,$H,$d,$m,$y) = gmtime($secs + $zonesecs);
549 $zonesecs = int($zonesecs / 60);
551 my $ans = strftime
($fmt, $S, $M, $H, $d, $m, $y, -1, -1, -1);
555 $zonesecs = -$zonesecs;
559 $z .= sprintf("%02d%02d", int($zonesecs/60), $zonesecs % 60);
564 # Take a list of project names and produce a nicely formated table that
565 # includes owner links and descriptions. If the list is empty returns ''.
566 # The first argument may be a hash ref that contains options. The following
567 # options are available:
568 # target -- sets the target value of the owner link
569 # emptyok -- if true returns an empty table rather than ''
570 # sizecol -- if true include a human-readable size column
571 # typecol -- if true include type column with hover info
572 # changed -- if true include a changed and idle column
573 sub projects_html_list
{
575 if (defined($_[0]) && ref($_[0]) eq 'HASH') {
578 return '' unless @_ || (defined($options->{emptyok
}) && $options->{emptyok
});
579 require Girocco
::Project
;
582 $target = " target=\""._escapeHTML
($options->{target
})."\""
583 if defined($options->{target
});
584 my $withsize = defined($options->{sizecol
}) && $options->{sizecol
};
585 my $withtype = defined($options->{typecol
}) && $options->{typecol
};
586 my $withchanged = defined($options->{changed
}) && $options->{changed
};
588 $sizehead = substr(<<EOT, 0, -1) if $withsize;
589 <th class="sizecol"><span class="hover">Size<span><span class="head" _data="Size"></span
590 /><span class="none" /><br />(</span>Fork size excludes objects borrowed from the parent.<span class="none">)</span></span></span></th
594 $typehead = '<th>Type</th>' if $withtype;
596 $chghead = substr(<<EOT, 0, -1) if $withchanged;
597 <th><span class="hover">Changed<span><span class="head" _data="Changed"></span
598 /><span class="none" /><br />(</span>The last time a ref change was received by this site.<span class="none">)</span></span></span></th
599 ><th><span class="hover">Idle<span><span class="head" _data="Idle"></span
600 /><span class="none" /><br />(</span>The most recent committer time in <i>refs/heads</i>.<span class="none">)</span></span></span></th
604 <table class='projectlist'><tr valign="top" align="left"><th>Project</th>$sizehead$typehead$chghead<th class="desc">Description</th></tr>
606 my $trclass = ' class="odd"';
607 foreach (sort({lc($a) cmp lc($b)} @_)) {
608 if (Girocco
::Project
::does_exist
($_, 1)) {
609 my $proj = Girocco
::Project
->load($_);
610 my $projname = $proj->{name
}.".git";
611 my $projdesc = $proj->{desc
}||'';
612 utf8
::decode
($projdesc) if utf8
::valid
($projdesc);
615 my $psize = $proj->{reposizek
};
616 $psize = undef unless defined($psize) && $psize =~ /^\d+$/;
617 $psize = 0 if !defined($psize) && $proj->is_empty;
618 if (!defined($psize)) {
623 $psize = human_size
($psize * 1024);
624 $psize =~ s/ /\ /g;
626 $sizecol = '<td class="sizecol">'.$psize.'</td>';
630 if ($proj->{mirror
}) {
631 my $url = _escapeHTML
($proj->{url
});
632 $typecol = substr(<<EOT, 0, -1);
633 <td class="type"><span class="hover">mirror<span class="nowrap"><span class="before" _data="$url"><span class="none"> <a href="$url" rel="nofollow">(URL)</a></span></span></span></span></td>
636 my $users = @
{$proj->{users
}};
638 $users .= 's' unless @
{$proj->{users
}} == 1;
639 my $userlist = join(', ', sort({lc($a) cmp lc($b)} @
{$proj->{users
}}));
640 my $spncls = length($userlist) > 25 ?
'' : ' class="nowrap"';
641 $typecol = $userlist ?
substr(<<EOT, 0, -1) : substr(<<EOT, 0, -1);
642 <td
class="type"><span
class="hover">$users<span
$spncls><br
class="none" />$userlist</span
></span></td
>
644 <td
class="type">$users</td
>
651 my $changetime = $proj->{lastchange
};
654 $ts = parse_rfc2822_date
($changetime, \
$tz);
655 my $ct = _strftime
("%Y-%m-%d %T %z", $ts, $tz);
656 $rel = "<span class=\"hover\">" .
657 _rel_age
(time - $ts) .
658 "<span class=\"nowrap\"><span class=\"before\" _data=\"$changetime\"></span><span class=\"none\"><br />$ct</span></span></span>";
662 $changecol = substr(<<EOT, 0, -1);
663 <td class="change">$rel</td>
665 my $idletime = $proj->{lastactivity
};
667 $idlesecs = parse_any_date
($idletime, \
$tz) if $idletime;
669 my $idle2822 = _strftime
("%a, %d %b %Y %T %z", $idlesecs, $tz);
670 my $ct = _strftime
("%Y-%m-%d %T %z", $idlesecs, $tz);
671 $rel = "<span class=\"hover\">" .
672 _rel_idle
(time - $idlesecs) .
673 "<span class=\"nowrap\"><span class=\"before\" _data=\"$idle2822\"></span><span class=\"none\"><br />$ct</span></span></span>";
677 $changecol .= substr(<<EOT, 0, -1);
678 <td class="idle">$rel</td>
682 <tr valign="top"$trclass><td><a href="@{[url_path($Girocco::Config::gitweburl)]}/$projname"$target
683 >@{[_escapeHTML($projname)]}</td>$sizecol$typecol$changecol<td>@{[_escapeHTML($projdesc)]}</td></tr>
685 $trclass = $trclass ?
'' : ' class="odd"';
692 return ($count || (defined($options->{emptyok
}) && $options->{emptyok
})) ?
$html : '';
698 jan
=> 0, feb
=> 1, mar
=> 2, apr
=> 3, may
=> 4, jun
=> 5,
699 jul
=> 6, aug
=> 7, sep
=> 8, oct => 9, nov
=> 10, dec
=> 11
703 # Should be in "date '+%a, %d %b %Y %T %z'" format as saved to lastgc, lastrefresh and lastchange
704 # The leading "%a, " is optional, returns undef if unrecognized date. This is also known as
705 # RFC 2822 date format and git's '%cD', '%aD' and --date=rfc2822 format.
706 # If the second argument is a SCALAR ref, its value will be set to the TZ offset in seconds
707 sub parse_rfc2822_date
{
708 my $dstr = shift || '';
709 my $tzoff = shift || '';
710 $dstr = $1 if $dstr =~/^[^\s]+,\s*(.*)$/;
711 return undef unless $dstr =~
712 /^\s*(\d{1,2})\s+([A-Za-z]{3})\s+(\d{4})\s+(\d{1,2}):(\d{2}):(\d{2})\s+([+-]\d{4})\s*$/;
713 my ($d,$b,$Y,$H,$M,$S,$z) = ($1,$2,$3,$4,$5,$6,$7);
714 my $m = $_month_names{lc($b)};
715 return undef unless defined($m);
716 my $seconds = timegm
(0+$S, 0+$M, 0+$H, 0+$d, 0+$m, 0+$Y);
717 my $offset = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
718 $offset = -$offset if substr($z,0,1) eq '-';
719 $$tzoff = $offset if ref($tzoff) eq 'SCALAR';
720 return $seconds - $offset;
723 # Will parse any supported date format. Actually there are three formats
724 # currently supported:
725 # 1. RFC 2822 (uses parse_rfc2822_date)
726 # 2. RFC 3339 / ISO 8601 (T may be ' ' or '_', 'Z' is optional or may be 'UTC', ':' optional in TZ)
727 # 3. Same as #2 except no colons or hyphens allowed and hours MUST be 2 digits
728 # 4. unix seconds since epoch with optional +/- trailing TZ (may not have a ':')
729 # Returns undef if unsupported date.
730 # If the second argument is a SCALAR ref, its value will be set to the TZ offset in seconds
732 my $dstr = shift || '';
733 my $tzoff = shift || '';
734 if ($dstr =~ /^\s*([-+]?\d+)(?:\s+([-+]\d{4}))?\s*$/) {
740 $off = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
741 $off = -$off if substr($z,0,1) eq '-';
743 $$tzoff = $off if ref($tzoff) eq 'SCALAR';
746 if ($dstr =~ /^\s*(\d{4})-(\d{2})-(\d{2})[Tt _](\d{1,2}):(\d{2}):(\d{2})(?:[ _]?([Zz]|[Uu][Tt][Cc]|(?:[-+]\d{1,2}:?\d{2})))?\s*$/ ||
747 $dstr =~ /^\s*(\d{4})(\d{2})(\d{2})[Tt _](\d{2})(\d{2})(\d{2})(?:[ _]?([Zz]|[Uu][Tt][Cc]|(?:[-+]\d{2}\d{2})))?\s*$/) {
748 my ($Y,$m,$d,$H,$M,$S,$z) = ($1,$2,$3,$4,$5,$6,$7||'');
749 my $seconds = timegm
(0+$S, 0+$M, 0+$H, 0+$d, $m-1, 0+$Y);
750 defined($z) && $z ne '' or $z = 'Z';
753 substr($z,1,0) = '0' if length($z) == 4;
755 if ($z ne 'Z' && $z ne 'UTC') {
756 $off = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
757 $off = -$off if substr($z,0,1) eq '-';
759 $$tzoff = $off if ref($tzoff) eq 'SCALAR';
760 return $seconds - $off;
762 return parse_rfc2822_date
($dstr, $tzoff);
765 # Input is a number such as a minute interval
766 # Return value is a random number between the input and 1.25*input
767 # This can be used to randomize the update and gc operations a bit to avoid
768 # having them all end up all clustered together
770 my $input = shift || 0;
771 return $input unless $input;
772 return $input + int(rand(0.25 * $input));
775 # Open a pipe to a new sendmail process. The '-i' option is always passed to
776 # the new process followed by any addtional arguments passed in. Note that
777 # the sendmail process is only expected to understand the '-i', '-t' and '-f'
778 # options. Using any other options via this function is not guaranteed to work.
779 # A list of recipients may follow the options. Combining a list of recipients
780 # with the '-t' option is not recommended.
782 return undef unless @_;
783 die "\$Girocco::Config::sendmail_bin is unset or not executable!\n"
784 unless $Girocco::Config
::sendmail_bin
&& -x
$Girocco::Config
::sendmail_bin
;
785 my $result = open(my $pipe, '|-', $Girocco::Config
::sendmail_bin
, '-i', @_);
786 return $result ?
$pipe : undef;
789 # Open a pipe that works similarly to a mailer such as /usr/bin/mail in that
790 # if the first argument is '-s', a subject line will be automatically added
791 # (using the second argument as the subject). Any remaining arguments are
792 # expected to be recipient addresses that will be added to an explicit To:
793 # line as well as passed on to sendmail_pipe. In addition an
794 # "Auto-Submitted: auto-generated" header is always added as well as a suitable
798 if (@_ >= 2 && $_[0] eq '-s') {
802 my $tolist = join(", ", @_);
803 unshift(@_, '-f', $Girocco::Config
::sender
) if $Girocco::Config
::sender
;
804 my $pipe = sendmail_pipe
(@_);
806 print $pipe "From: \"$Girocco::Config::name\" ",
807 "($Girocco::Config::title) ",
808 "<$Girocco::Config::admin>\n";
809 print $pipe "To: $tolist\n";
810 print $pipe "Subject: $subject\n" if defined($subject);
811 print $pipe "MIME-Version: 1.0\n";
812 print $pipe "Content-Type: text/plain; charset=utf-8; format=fixed\n";
813 print $pipe "Content-Transfer-Encoding: 8bit\n";
814 print $pipe "X-Girocco: $Girocco::Config::gitweburl\n"
815 unless $Girocco::Config
::suppress_x_girocco
;
816 print $pipe "Auto-Submitted: auto-generated\n";
824 return undef unless defined($val);
825 $val =~ s/[\r\n]+$//s;
826 return undef unless $val =~ /^\d+$/;
828 return undef unless $val >= 1;
832 # Returns the number of "online" cpus or undef if undetermined
834 my @confcpus = $^O
eq "linux" ?
835 qw(_NPROCESSORS_ONLN NPROCESSORS_ONLN) :
836 qw(NPROCESSORS_ONLN _NPROCESSORS_ONLN) ;
837 my $cpus = _goodval
(get_cmd
('getconf', $confcpus[0]));
838 return $1 if defined($cpus) && $cpus =~ /^(\d+)$/;
839 $cpus = _goodval
(get_cmd
('getconf', $confcpus[1]));
840 return $1 if defined($cpus) && $cpus =~ /^(\d+)$/;
841 if ($^O
ne "linux") {
842 my @sysctls = qw(hw.ncpu);
843 unshift(@sysctls, qw(hw.availcpu)) if $^O
eq "darwin";
844 foreach my $mib (@sysctls) {
845 $cpus = _goodval
(get_cmd
('sysctl', '-n', $mib));
846 return $1 if defined($cpus) && $cpus =~ /^(\d+)$/;
852 # Returns the system page size in bytes or undef if undetermined
853 # This should never fail on a POSIX system
855 use POSIX
":unistd_h";
856 my $pagesize = sysconf
(_SC_PAGESIZE
);
857 return undef unless defined($pagesize) && $pagesize =~ /^\d+$/;
858 $pagesize = 0 + $pagesize;
859 return undef unless $pagesize >= 256;
863 # Returns the amount of available physical memory in bytes
864 # This may differ from the actual amount of physical memory installed
865 # Returns undef if this cannot be determined
867 my $pagesize = sys_pagesize
;
868 if ($pagesize && $^O
eq "linux") {
869 my $pages = _goodval
(get_cmd
('getconf', '_PHYS_PAGES'));
870 return $pagesize * $pages if $pages;
872 if ($^O
ne "linux") {
873 my @sysctls = qw(hw.physmem64);
874 unshift(@sysctls, qw(hw.memsize)) if $^O
eq "darwin";
875 foreach my $mib (@sysctls) {
876 my $memsize = _goodval
(get_cmd
('sysctl', '-n', $mib));
877 return $memsize if $memsize;
879 my $memsize32 = _goodval
(get_cmd
('sysctl', '-n', 'hw.physmem'));
880 return $memsize32 if $memsize32 && $memsize32 <= 2147483647;
882 my $pages = _goodval
(get_cmd
('sysctl', '-n', 'hw.availpages'));
883 return $pagesize * $pages if $pages;
885 return 2147483647 + 1 if $memsize32;
890 sub _get_max_conf_suffixed_size
{
892 return undef unless defined $conf && $conf =~ /^(\d+)([kKmMgG]?)$/;
893 my ($val, $suffix) = (0+$1, lc($2));
894 $val *= 1024 if $suffix eq 'k';
895 $val *= 1024 * 1024 if $suffix eq 'm';
896 $val *= 1024 * 1024 * 1024 if $suffix eq 'g';
900 sub _make_suffixed_size
{
902 return $size if $size % 1024;
904 return "${size}k" if $size % 1024;
906 return "${size}m" if $size % 1024;
911 # Return the value to pass to --window-memory= for git repack
912 # If the system memory or number of CPUs cannot be determined, returns "1g"
913 # Otherwise returns one third the available memory divided by the number of CPUs
914 # but never more than 1 gigabyte or max_gc_window_memory_size.
915 sub calc_windowmemory
{
916 my $cpus = online_cpus
;
917 my $memsize = sys_memsize
;
918 my $max = 1024 * 1024 * 1024;
919 if ($cpus && $memsize) {
920 $max = int($memsize / 3 / $cpus);
921 $max = 1024 * 1024 * 1024 if $max >= 1024 * 1024 * 1024;
923 my $maxconf = _get_max_conf_suffixed_size
($Girocco::Config
::max_gc_window_memory_size
);
924 $max = $maxconf if defined($maxconf) && $maxconf && $max > $maxconf;
925 return _make_suffixed_size
($max);
928 # Return the value to set as core.bigFileThreshold for git repack
929 # If the system memory cannot be determined, returns "256m"
930 # Otherwise returns the available memory divided by 16
931 # but never more than 512 megabytes or max_gc_big_file_threshold_size.
932 sub calc_bigfilethreshold
{
933 my $memsize = sys_memsize
;
934 my $max = 256 * 1024 * 1024;
936 $max = int($memsize / 16);
937 $max = 512 * 1024 * 1024 if $max >= 512 * 1024 * 1024;
939 my $maxconf = _get_max_conf_suffixed_size
($Girocco::Config
::max_gc_big_file_threshold_size
);
940 $max = $maxconf if defined($maxconf) && $maxconf && $max > $maxconf;
941 return _make_suffixed_size
($max);
944 # Return the value to use when deciding whether or not to re-calculate object deltas
945 # If there are no more than this many objects then deltas will be recomputed in
946 # order to create more efficient pack files. The new_delta_threshold value
947 # is constrained to be at least 1000 * cpu cores and no more than 100000.
948 # The default is sys_memsize rounded up to the nearest multiple of 256 MB and
949 # then 5000 per 256 MB or 50000 if we cannot determine memory size but never
950 # more than 100000 or less than 1000 * cpu cores.
951 sub calc_redeltathreshold
{
952 my $cpus = online_cpus
|| 1;
953 if (defined($Girocco::Config
::new_delta_threshold
) &&
954 $Girocco::Config
::new_delta_threshold
=~ /^\d+/) {
955 my $ndt = 0 + $Girocco::Config
::new_delta_threshold
;
956 if ($ndt >= $cpus * 1000) {
957 return $ndt <= 100000 ?
$ndt : 100000;
961 my $memsize = sys_memsize
;
963 my $quantum = 256 * 1024 * 1024;
964 $calcval = 5000 * int(($memsize + ($quantum - 1)) / $quantum);
965 $calcval = 1000 * $cpus if $calcval < 1000 * $cpus;
966 $calcval = 100000 if $calcval > 100000;
971 # $1 => thing to test
972 # $2 => optional directory, if given and -e "$2/$1$3", then return false
973 # $3 => optional, defaults to ''
974 sub has_reserved_suffix
{
975 no warnings
; # avoid silly 'unsuccessful stat on filename with \n' warning
976 my ($name, $dir, $ext) = @_;
977 $ext = '' unless defined $ext;
978 return 0 unless defined $name && $name =~ /\.([^.]+)$/;
979 return 0 unless exists $Girocco::Config
::reserved_suffixes
{lc($1)};
980 return 0 if defined $dir && -e
"$dir/$name$ext";
984 # mostly undoes effect of `use CGI::Carp qw(fatalsToBrowser);`
985 # mostly undoes effect of `use CGI::Carp qw(warningsToBrowser);`
986 sub noFatalsToBrowser
{
987 delete $SIG{__DIE__
};
988 delete $SIG{__WARN__
};
989 undef *CORE
::GLOBAL
::die;
990 *CORE
::GLOBAL
::die = sub {
992 my $ec = $! || ($?
>> 8) || 255;
993 my (undef, $fn, $li) = caller(0);
994 my $loc = " at " . $fn . " line " . $li . ".\n";
996 $msg = join("", @_) if @_;
997 $msg = "Died" if $msg eq "";
998 $msg .= $loc unless $msg =~ /\n$/;
1000 printf STDERR
"%s", $msg;
1003 undef *CORE
::GLOBAL
::warn;
1004 *CORE
::GLOBAL
::warn = sub {
1006 my (undef, $fn, $li) = caller(0);
1007 my $loc = " at " . $fn . " line " . $li . ".\n";
1009 $msg = join("", @_) if @_;
1010 $msg = "Warning: something's wrong" if $msg eq "";
1011 $msg .= $loc unless $msg =~ /\n$/;
1012 printf STDERR
"%s", $msg;
1016 # mimics Git's symref reading but only for HEAD
1017 # returns undef on failure otherwise an string that is
1018 # either an all-hex (lowercase) value or starts with "refs/"
1020 my $headpath = $_[0] . "/HEAD";
1022 my $rl = readlink($headpath);
1023 return defined($rl) && $rl =~ m
,^refs
/[^\x00-\x1f \x7f~^:\\*?
[]+$, ?
$rl : undef;
1025 open my $fd, '<', $headpath or return undef;
1032 defined($hv) or return undef;
1034 $hv =~ m
,^ref:\s
*(refs
/[^\x00-\x1f \x7f~^:\\*?
[]+)$, and return $1;
1035 $hv =~ m/^[0-9a-fA-F]{40,}$/ and return lc($hv);
1039 # same as read_HEAD_ref but returns undef
1040 # unless the result starts with "refs/"
1041 sub read_HEAD_symref
{
1042 my $hv = read_HEAD_ref
(@_);
1043 return defined($hv) && $hv =~ m
,^refs
/., ?
$hv : undef;
1046 # similar to Git's test except that GIT_OBJECT_DIRECTORY is ignored
1049 defined($gd) && $gd ne "" && -d
$gd or return undef;
1050 -d
"$gd/objects" && -x
"$gd/objects" or return 0;
1051 -d
"$gd/refs" && -x
"$gd/refs" or return 0;
1052 if (-l
"$gd/HEAD") {
1053 my $rl = readlink("$gd/HEAD");
1054 defined($rl) && $rl =~ m
,^refs
/., or return 0;
1055 -e
"$gd/HEAD" or return 1;
1057 open my $fd, '<', "$gd/HEAD" or return 0;
1064 defined $hv or return 0;
1066 $hv =~ m
,^ref:\s
*refs
/., and return 1;
1067 return $hv =~ /^[0-9a-f]{40}/;
1070 # Returns a PATH properly prefixed which guarantees that Git is found and the
1071 # basedir/bin utilities are found as intended. $ENV{PATH} is LEFT UNCHANGED!
1072 # Caller is responsible for assigning result to $ENV{PATH} or otherwise
1073 # arranging for it to be used. If $ENV{PATH} already has the proper prefix
1074 # then it's returned as-is (making this function idempotent).
1075 # Will die if it cannot determine a suitable full PATH.
1076 # Result is cached so all calls after the first are practically free.
1077 my $var_git_exec_path;
1079 defined($Girocco::Config
::var_git_exec_path
) && $Girocco::Config
::var_git_exec_path
ne "" and
1080 $var_git_exec_path = $Girocco::Config
::var_git_exec_path
;
1081 if (!defined($var_git_exec_path) || $var_git_exec_path eq "") {
1082 defined($Girocco::Config
::basedir
) && $Girocco::Config
::basedir
ne "" &&
1083 -d
$Girocco::Config
::basedir
&& -r _
&& -x _
or
1084 die "invalid \$Girocco::Config::basedir setting: $Girocco::Config::basedir\n";
1085 my $varsfile = $Girocco::Config
::basedir
. "/shlib_vars.sh";
1086 if (-f
$varsfile && -r _
) {
1088 if (open $vars, '<', $varsfile) {
1089 # last value for var_git_exec_path wins
1092 substr($_, 0, 19) eq "var_git_exec_path=\"" or next;
1093 substr($_, -1, 1) eq "\"" or next;
1094 my $xd = substr($_, 19, -1);
1095 $var_git_exec_path = $xd if -d
$xd && -r _
&& -x _
;
1100 if (!defined($var_git_exec_path)) {
1101 my $xd = get_git
("--exec-path");
1102 $var_git_exec_path = $xd if defined($xd) &&
1103 (chomp $xd, $xd) ne "" && -d
$xd && -r _
&& -x _
;
1105 defined($var_git_exec_path) && $var_git_exec_path ne "" or
1106 die "could not determine \$(git --exec-path) value\n";
1107 $var_git_exec_path = $1 if $var_git_exec_path =~ m
|^(/.+)$|;
1109 my $prefix = "$var_git_exec_path:$Girocco::Config::basedir/bin:";
1110 if (substr($ENV{PATH
}, 0, length($prefix)) eq $prefix) {
1113 return $prefix . $ENV{PATH
};
1117 # Note that Perl performs a "shellish" test in the Perl_do_exec3 function from doio.c,
1118 # but it has slightly different semantics in that whitespace does not automatically
1119 # make something "shellish". The semantics used here more closely match Git's
1120 # semantics so that Girocco will provide an interpretation more similar to Git's.
1122 return unless defined(local $_ = shift);
1123 return 1 if m
#[][\$&*(){}'";:=\\|?<>~`\#\s]#; # contains metacharacters
1124 return 0; # probably not shellish
1127 # Works just like the shlib.sh function git_add_config
1128 # except it takes two arguments, first the variable name, second the value
1129 # For example: git_add_config("gc.auto", "0")
1130 # No extra quoting is performed!
1131 # If the name or value requires special quoting, it must be provided by the caller!
1132 # Note this function will only be effective when running Git 1.7.3 or later
1133 sub git_add_config
{
1134 my ($name, $val) = @_;
1135 defined($name) && defined($val) or return;
1136 $name ne "" or return;
1137 my $gcp = $ENV{GIT_CONFIG_PARAMETERS
};
1138 defined($gcp) or $gcp = '';
1139 $gcp eq "" or $gcp = $gcp . " ";
1140 $gcp .= "'" . $name . '=' . $val . "'";
1141 $ENV{GIT_CONFIG_PARAMETERS
} = $gcp;
1145 package Girocco
::Util
::JSON
::Boolean
;
1146 use overload
'""' => \
&strval
;
1148 my $class = shift || __PACKAGE__
;
1150 return bless \
$val, $class;
1157 # returns a reference to a suitable object that will
1158 # encode to "true" or "false" when passed to to_json
1159 # based on the value passed to this function
1160 # For example, `print to_json(json_bool(1))` prints `true`.
1162 return Girocco
::Util
::JSON
::Boolean
->new($_[0]);
1165 # returns a utf8 encoded result that strictly conforms to
1166 # the JSON standard aka RFC 8259.
1167 # first argument is a scalar or a ref to a SCALAR, ARRAY or HASH
1168 # second argument, if true, requests a "pretty" result
1170 my ($val, $prt) = @_;
1171 $prt = 1 if $prt && !looks_like_number
($prt);
1172 $prt = 0 unless $prt;
1173 return _json_value
($val, 0+$prt, "");
1177 my ($val, $prt, $ndt) = @_;
1178 defined($val) or return "null";
1179 $val = $$val if ref($val) eq 'SCALAR';
1181 $r eq 'HASH' and return _json_hash
($val, $prt, $ndt);
1182 $r eq 'ARRAY' and return _json_array
($val, $prt, $ndt);
1183 $r eq 'Girocco::Util::JSON::Boolean' and
1184 return $val ?
"true" : "false";
1185 $r ne '' and $val = "".$val;
1186 looks_like_number
($val) and return "".(0+$val);
1187 return _json_str
("".$val);
1190 my %json_esc; BEGIN {%json_esc=(
1202 Encode
::is_utf8
($val) and utf8
::encode
($val);
1203 $val =~ s/([\\\042\b\t\n\f\r])/$json_esc{$1}/go;
1204 $val =~ s/([\x00-\x1f])/sprintf("\\u%04X",ord($1))/goe;
1205 return '"'.$val.'"';
1209 my ($val, $prt, $ndt) = @_;
1210 return '[]' unless @
{$val};
1212 $ans .= "\n" if $prt;
1215 for (my $i = 0; $i <= $#{$val}; ++$i) {
1216 $ans .= $ndt if $prt;
1217 $ans .= _json_value
(${$val}[$i], $prt, $ndt);
1218 $ans .= "," if $i < $#{$val};
1219 $ans .= "\n" if $prt;
1222 $ans .= $ndt if $prt;
1228 my ($val, $prt, $ndt) = @_;
1229 return '{}' unless %{$val};
1231 $ans .= "\n" if $prt;
1234 my @keys = sort(keys(%{$val}));
1235 for (my $i = 0; $i <= $#keys; ++$i) {
1236 $ans .= $ndt if $prt;
1237 $ans .= _json_str
("".$keys[$i]).":";
1238 $ans .= " " if $prt;
1239 $ans .= _json_value
(${$val}{$keys[$i]}, $prt, $ndt);
1240 $ans .= "," if $i < $#keys;
1241 $ans .= "\n" if $prt;
1244 $ans .= $ndt if $prt;
1249 # returns undef on error and sets $@ (otherwise $@ cleared)
1250 # if the JSON string to decode is "null" then undef is returned and $@ eq ""
1251 # $_[0] -> string value to decode from JSON
1252 # $_[1] -> if true return integers instead of json_bool for true/false
1253 # $_[2] -> if true strings are utf8::encode'd (i.e. they're bytes not chars)
1254 # returns scalar which will be an ARRAY or HASH ref for JSON array or hash values
1255 # using to_json(from_json($json_value)) will somewhat "normalize" $json_value
1256 # (and optionally pretty it up) and always recombine valid surrogate pairs
1259 eval {$ans = _from_jsonx
(@_)};
1263 # will die on bad input
1265 my ($val, $nobool, $enc) = @_;
1266 defined($val) or return undef;
1267 my $l = length($val);
1269 my $atom = _from_json_value
(\
$val, $l, $nobool, $enc);
1272 die "garbage found at offset ".pos($val);
1276 sub _from_json_value
{
1277 my ($val, $l, $nobool, $enc) = @_;
1279 my $c = substr($$val, pos($$val), 1);
1280 $c eq "" and die "unexpected end of input at offset ".pos($$val);
1281 $c eq "{" and return _from_json_hash
($val, $l, $nobool, $enc);
1282 $c eq "[" and return _from_json_array
($val, $l, $nobool, $enc);
1283 $c eq '"' and return _from_json_str
($val, $enc);
1284 index("-0123456789", $c) >= 0 and do {
1285 $$val =~ /\G(-?(?:0|[1-9]\d*)(?:\.\d+)?(?:[eE][-+]?\d+)?)/gc and
1286 return int($1) == $1 ?
int($1) : $1;
1287 die "invalid JSON number at offset ".pos($$val);
1289 $$val =~ /\Gnull\b/gc and return undef;
1290 $$val =~ /\Gtrue\b/gc and return $nobool?
1:json_bool
(1);
1291 $$val =~ /\Gfalse\b/gc and return $nobool?
0:json_bool
(0);
1292 die "invalid JSON value at offset ".pos($$val);
1295 my %json_unesc; BEGIN {%json_unesc=(
1305 sub _from_json_str
{
1306 my ($val, $enc) = @_;
1307 my $opos = pos($$val);
1308 $$val =~ /\G\042((?:[^\\\042]|\\.)*)\042/gsc and
1309 return _from_json_strval
($1, $opos+1, $enc);
1310 die "invalid JSON string starting at offset $opos";
1313 sub _from_json_strval
{
1314 my ($val, $pos, $enc) = @_;
1315 Encode
::is_utf8
($val) || utf8
::decode
($val) or
1316 die "invalid UTF-8 string starting at offset $pos";
1317 $val =~ s
{\\([\\\042btnfr
]|u
[0-9a
-fA
-F
]{4})}{
1318 substr($1,0,1) eq "u" ?
&{sub{
1319 my $c = hex(substr($1,1,4));
1320 0xD800 <= $c && $c <= 0xDFFF ?
1322 chr(hex(substr($1,1,4)))
1323 }} : $json_unesc{$1}
1325 $val =~ s
{\\u
([Dd
][89AaBb
][0-9a
-fA
-F
]{2})\\u
([Dd
][CcDdEeFf
][0-9a
-fA
-F
]{2})}{
1326 chr(( ((hex($1)&0x03FF)<<10) | (hex($2)&0x03FF) ) + 0x10000)
1328 !Encode
::is_utf8
($val) || utf8
::encode
($val) if $enc;
1332 sub _from_json_array
{
1333 my ($val, $l, $nobool, $enc) = @_;
1335 $$val =~ /\G\[/gc or die "expected '[' at offset ".pos($$val);
1337 while (pos($$val) < $l && substr($$val, pos($$val), 1) ne "]") {
1338 $$val =~ /\G\s+/gc and next;
1339 !$wantcomma && substr($$val, pos($$val), 1) eq "," and
1340 die "unexpected comma (,) in JSON array at offset ".pos($$val);
1341 $wantcomma && !($$val =~ /\G,/gc) and
1342 die "expected comma (,) or right-bracket (]) in JSON array at offset ".pos($$val);
1343 push(@a, _from_json_value
($val, $l, $nobool, $enc));
1346 $$val =~ /\G\]/gc or die "expected ']' at offset ".pos($$val);
1350 sub _from_json_hash
{
1351 my ($val, $l, $nobool, $enc) = @_;
1353 $$val =~ /\G\{/gc or die "expected '{' at offset ".pos($$val);
1356 while (pos($$val) < $l && substr($$val, pos($$val), 1) ne "}") {
1357 $$val =~ /\G\s+/gc and next;
1358 !$wantc && index(":,", substr($$val, pos($$val), 1)) >= 0 and
1359 die "unexpected colon (:) or comma (,) in JSON hash at offset ".pos($$val);
1360 $wantc eq ":" && !($$val =~ /\G:/gc) and
1361 die "expected colon (:) in JSON hash at offset ".pos($$val);
1362 $wantc eq "," && !($$val =~ /\G,/gc) and
1363 die "expected comma (,) or right-brace (}) in JSON hash at offset ".pos($$val);
1364 $wantc and $$val =~ /\G\s+/gc;
1365 $wantc eq "," and $wantc = "";
1366 !$wantc && substr($$val, pos($$val), 1) ne '"' and
1367 die "expected double-quote (\") in JSON hash at offset ".pos($$val);
1369 $k = _from_json_str
($val, $enc);
1373 $h{$k} = _from_json_value
($val, $l, $nobool, $enc);
1376 $wantc ne ":" or die "expected ':' at offset ".pos($$val);
1377 $$val =~ /\G\}/gc or die "expected '}' at offset ".pos($$val);
1381 # $_[0] -> full absolute path to a git ".git" directory
1382 # $_[1] -> "old" ref hash value
1383 # $_[2] -> "new" ref hash value
1385 # scalar context: "..." -- if forced ref update detected (i.e. NOT a fast-forward)
1386 # ".." -- any other condition (i.e. fast-forward/creation/deletion/no change/etc.)
1387 # array context: [0] -> scalar context result
1388 # [1] -> true value if a git command had to be run
1390 return '..' unless defined($_[0]);
1391 my ($git_dir, $old, $new) = @_;
1392 return '..' unless defined($old) && defined($new) && $old !~ /^0+$/ && $new !~ /^0+$/ && $old ne $new;
1393 # In many cases `git merge-base` is slower than this even if using the
1394 # `--is-ancestor` option available since Git 1.8.0, but it's never faster
1395 my $ans = get_git
("--git-dir=$git_dir", "rev-list", "-n", "1", "^$new^0", "$old^0", "--") ?
'...' : '..';
1396 return wantarray ?
($ans, 1) : $ans;