install.sh: verify correct install user
[girocco.git] / Girocco / Util.pm
blob4be81646e2b05886022c163673303d9ab23a2b10
1 package Girocco::Util;
3 use 5.008;
4 use strict;
5 use warnings;
7 use Girocco::Config;
8 use Time::Local;
9 use Encode;
11 BEGIN {
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
24 clean_email_multi read_HEAD_symref read_config_file
25 read_config_file_hash is_git_dir git_bool util_path
26 is_shellish read_HEAD_ref);
29 my $encoder;
30 BEGIN {
31 $encoder = Encode::find_encoding('Windows-1252') ||
32 Encode::find_encoding('ISO-8859-1') or
33 die "failed to load ISO-8859-1 encoder\n";
36 sub to_utf8($;$) {
37 my ($str, $encode) = @_;
38 return undef unless defined $str;
39 my $ans;
40 if (Encode::is_utf8($str) || utf8::decode($str)) {
41 $ans = $str;
42 } else {
43 $ans = $encoder->decode($str, Encode::FB_DEFAULT);
45 utf8::encode($ans) if $encode;
46 return $ans;
49 BEGIN {require "Girocco/extra/capture_command.pl"}
51 # Return the entire output sent to stdout from running a command
52 # Any output the command sends to stderr is discarded
53 # Returns undef if there was an error running the command (see $!)
54 sub get_cmd {
55 my ($status, $result) = capture_command(1, undef, @_);
56 return defined($status) && $status == 0 ? $result : undef;
59 # Same as get_cmd except configured git binary is automatically provided
60 # as the first argument to get_cmd
61 sub get_git {
62 return get_cmd($Girocco::Config::git_bin, @_);
65 sub scrypt {
66 my ($pwd) = @_;
67 crypt($pwd||'', join ('', ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]));
70 sub jailed_file {
71 my ($filename) = @_;
72 $filename =~ s,^/,,;
73 $Girocco::Config::chroot."/$filename";
76 sub lock_file {
77 my ($path) = @_;
79 $path .= '.lock';
81 use Errno qw(EEXIST);
82 use Fcntl qw(O_WRONLY O_CREAT O_EXCL);
83 use IO::Handle;
84 my $handle = new IO::Handle;
86 unless (sysopen($handle, $path, O_WRONLY|O_CREAT|O_EXCL)) {
87 my $cnt = 0;
88 while (not sysopen($handle, $path, O_WRONLY|O_CREAT|O_EXCL)) {
89 ($! == EEXIST) or die "$path open failed: $!";
90 ($cnt++ < 16) or die "$path open failed: cannot open lockfile";
91 sleep(1);
94 # XXX: filedb-specific
95 chmod 0664, $path or die "$path g+w failed: $!";
97 $handle;
100 sub _is_passwd_file {
101 return defined($_[0]) && $_[0] eq jailed_file('/etc/passwd');
104 sub _run_update_pwd_db {
105 my ($path, $updatearg) = @_;
106 my @cmd = ($Girocco::Config::basedir.'/bin/update-pwd-db', "$path");
107 push(@cmd, $updatearg) if $updatearg;
108 system(@cmd) == 0 or die "update-pwd-db failed: $?";
111 sub unlock_file {
112 my ($path, $noreplace, $updatearg) = @_;
114 if (!$noreplace) {
115 _run_update_pwd_db("$path.lock", $updatearg)
116 if $Girocco::Config::update_pwd_db && _is_passwd_file($path);
117 rename "$path.lock", $path or die "$path unlock failed: $!";
118 } else {
119 unlink "$path.lock" or die "$path unlock failed: $!";
123 sub filedb_atomic_append {
124 my ($file, $line, $updatearg) = @_;
125 my $id = 65536;
127 open my $src, '<', $file or die "$file open for reading failed: $!";
128 my $dst = lock_file($file);
130 while (<$src>) {
131 my $aid = (split /:/)[2];
132 $id = $aid + 1 if ($aid >= $id);
134 print $dst $_ or die "$file(l) write failed: $!";
137 $line =~ s/\\i/$id/g;
138 print $dst "$line\n" or die "$file(l) write failed: $!";
140 close $dst or die "$file(l) close failed: $!";
141 close $src;
143 unlock_file($file, 0, $updatearg);
145 $id;
148 sub filedb_atomic_edit {
149 my ($file, $fn, $updatearg) = @_;
151 open my $src, '<', $file or die "$file open for reading failed: $!";
152 my $dst = lock_file($file);
154 while (<$src>) {
155 print $dst $fn->($_) or die "$file(l) write failed: $!";
158 close $dst or die "$file(l) close failed: $!";
159 close $src;
161 unlock_file($file, 0, $updatearg);
164 sub filedb_atomic_grep {
165 my ($file, $fn) = @_;
166 my @results = ();
168 open my $src, '<', $file or die "$file open for reading failed: $!";
169 my $dst = lock_file($file);
171 while (<$src>) {
172 my $result = $fn->($_);
173 push(@results, $result) if $result;
176 close $dst or die "$file(l) close failed: $!";
177 close $src;
179 unlock_file($file, 1);
180 return @results;
183 sub filedb_grep {
184 my ($file, $fn) = @_;
185 my @results = ();
187 open my $src, '<', $file or die "$file open for reading failed: $!";
189 while (<$src>) {
190 my $result = $fn->($_);
191 push(@results, $result) if $result;
194 close $src;
196 return @results;
199 sub valid_email {
200 my $email = shift;
201 defined($email) or $email = '';
202 return $email =~ /^[a-zA-Z0-9+._-]+@[a-zA-Z0-9.-]+$/;
205 sub clean_email_multi {
206 my $input = shift;
207 defined($input) or $input = '';
208 $input =~ s/^\s+//; $input =~ s/\s+$//;
209 my %seen = ();
210 my @newlist = ();
211 foreach (split(/\s*,\s*/, $input)) {
212 next if $_ eq "";
213 $seen{lc($_)} = 1, push(@newlist, $_) unless $seen{lc($_)};
215 return join(",", @newlist);
218 sub valid_email_multi {
219 # each email address must be a valid_email but we silently
220 # ignore extra spaces at the beginning/end and around any comma(s)
221 foreach (split(/,/, clean_email_multi(shift))) {
222 return 0 unless valid_email($_);
224 return 1;
227 sub valid_web_url {
228 my $url = shift;
229 defined($url) or $url = '';
230 return $url =~
231 /^https?:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~:?&=;-]*)?(#[a-zA-Z0-9._-]+)?$/;
234 sub valid_repo_url {
235 my $url = shift || '';
236 # Currently neither username nor password is allowed in the URL and IPv6
237 # literal addresses are not accepted either.
238 $Girocco::Config::mirror_svn &&
239 $url =~ /^svn(\+https?)?:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/os
240 and return 1;
241 $Girocco::Config::mirror_darcs &&
242 $url =~ /^darcs:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/os
243 and return 1;
244 $Girocco::Config::mirror_bzr &&
245 $url =~ /^bzr:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/os
246 and return 1;
247 $Girocco::Config::mirror_hg &&
248 $url =~ /^hg\+https?:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/os
249 and return 1;
250 return $url =~ /^(https?|git):\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/;
253 sub extract_url_hostname {
254 my $url = shift || '';
255 if ($url =~ m,^bzr://,) {
256 $url =~ s,^bzr://,,;
257 return 'launchpad.net' if $url =~ /^lp:/;
259 return undef unless $url =~ m,^[A-Za-z0-9+.-]+://[^/],;
260 $url =~ s,^[A-Za-z0-9+.-]+://,,;
261 $url =~ s,^([^/]+).*$,$1,;
262 $url =~ s/:[0-9]*$//;
263 $url =~ s/^[^\@]*[\@]//;
264 return $url ? $url : undef;
267 # See these RFCs:
268 # RFC 1034 section 3.5
269 # RFC 1123 section 2.1
270 # RFC 1738 section 3.1
271 # RFC 2606 sections 2 & 3
272 # RFC 3986 section 3.2.2
273 sub is_dns_hostname {
274 my $host = shift;
275 defined($host) or $host = '';
276 return 0 if $host eq '' || $host =~ /\s/;
277 # first remove a trailing '.'
278 $host =~ s/\.$//;
279 return 0 if length($host) > 255;
280 my $octet = '(?:\d|[1-9]\d|1\d{2}|2[0-4]\d|25[0-5])';
281 return 0 if $host =~ /^$octet\.$octet\.$octet\.$octet$/o;
282 my @labels = split(/[.]/, $host, -1);
283 return 0 unless @labels && @labels >= $Girocco::Config::min_dns_labels;
284 # now check each label
285 foreach my $label (@labels) {
286 return 0 unless length($label) > 0 && length($label) <= 63;
287 return 0 unless $label =~ /^[A-Za-z0-9](?:[A-Za-z0-9-]*[A-Za-z0-9])?$/;
289 # disallow RFC 2606 names provided at least two labels are present
290 if (@labels >= 2) {
291 my $tld = lc($labels[-1]);
292 return 0 if
293 $tld eq 'test' ||
294 $tld eq 'example' ||
295 $tld eq 'invalid' ||
296 $tld eq 'localhost';
297 my $sld = lc($labels[-2]);
298 return 0 if $sld eq 'example' &&
299 ($tld eq 'com' || $tld eq 'net' || $tld eq 'org');
301 return 1;
304 sub is_our_hostname {
305 my $test = shift || '';
306 $test =~ s/\.$//;
307 my %names = ();
308 my @urls = (
309 $Girocco::Config::gitweburl,
310 $Girocco::Config::gitwebfiles,
311 $Girocco::Config::webadmurl,
312 $Girocco::Config::bundlesurl,
313 $Girocco::Config::htmlurl,
314 $Girocco::Config::httppullurl,
315 $Girocco::Config::httpbundleurl,
316 $Girocco::Config::httpspushurl,
317 $Girocco::Config::gitpullurl,
318 $Girocco::Config::pushurl
320 foreach my $url (@urls) {
321 if ($url) {
322 my $host = extract_url_hostname($url);
323 if (defined($host)) {
324 $host =~ s/\.$//;
325 $names{lc($host)} = 1;
329 return $names{lc($test)} ? 1 : 0;
332 my (%_oktags, %_badtags, %_canontags, $_canontagscreated, @_whitetags);
333 BEGIN {
334 # These are always okay (a "whitelist") even if they would
335 # otherwise not be allowed
336 @_whitetags = (qw(
337 .net 2d 3d 6502 68000 68008 68010 68020 68030 68040 68060
338 8086 80286 80386 80486 80586 c cc make www x
340 map({$_oktags{lc($_)}=1} @_whitetags, @Girocco::Config::allowed_tags);
341 # entries MUST be all lowercase to be effective
342 %_badtags = (
343 # These are "nonsense" or pointless tags
344 about=>1, after=>1, all=>1, also=>1, an=>1, and=>1, another=>1, any=>1,
345 are=>1, as=>1, at=>1, be=>1, because=>1, been=>1, before=>1, being=>1,
346 between=>1, both=>1, but=>1, by=>1, came=>1, can=>1, come=>1, could=>1,
347 did=>1, do=>1, each=>1, for=>1, from=>1, get=>1, got=>1, had=>1, has=>1,
348 have=>1, he=>1, her=>1, here=>1, him=>1, himself=>1, his=>1, how=>1,
349 if=>1, in=>1, into=>1, is=>1, it=>1, like=>1, make=>1, many=>1, me=>1,
350 might=>1, more=>1, most=>1, much=>1, must=>1, my=>1, never=>1, now=>1,
351 of=>1, oh=>1, on=>1, only=>1, or=>1, other=>1, our=>1, out=>1, over=>1,
352 said=>1, same=>1, see=>1, should=>1, since=>1, some=>1, still=>1,
353 such=>1, take=>1, than=>1, that=>1, the=>1, their=>1, them=>1, then=>1,
354 there=>1, these=>1, they=>1, this=>1, those=>1, through=>1, to=>1,
355 too=>1, under=>1, up=>1, very=>1, was=>1, way=>1, we=>1, well=>1,
356 were=>1, what=>1, where=>1, which=>1, while=>1, who=>1, with=>1,
357 would=>1, yea=>1, yeah=>1, you=>1, your=>1, yup=>1
359 # These are "offensive" tags with at least one letter escaped to
360 # avoid having this file trigger various safe-scan robots
361 $_badtags{"a\x73\x73"} = 1;
362 $_badtags{"a\x73\x73hole"} = 1;
363 $_badtags{"b\x30\x30b"} = 1;
364 $_badtags{"b\x30\x30bs"} = 1;
365 $_badtags{"b\x6f\x6fb"} = 1;
366 $_badtags{"b\x6f\x6fbs"} = 1;
367 $_badtags{"b\x75tt"} = 1;
368 $_badtags{"b\x75ttd\x69\x63k"} = 1;
369 $_badtags{"c\x6f\x63k"} = 1;
370 $_badtags{"c\x75\x6e\x74"} = 1;
371 $_badtags{"d\x69\x63k"} = 1;
372 $_badtags{"d\x69\x63kb\x75tt"} = 1;
373 $_badtags{"f\x75\x63k"} = 1;
374 $_badtags{"in\x63\x65st"} = 1;
375 $_badtags{"ph\x75\x63k"} = 1;
376 $_badtags{"p\x6f\x72n"} = 1;
377 $_badtags{"p\x6f\x72no"} = 1;
378 $_badtags{"p\x6f\x72nographic"} = 1;
379 $_badtags{"p\x72\x30n"} = 1;
380 $_badtags{"p\x72\x6fn"} = 1;
381 $_badtags{"r\x61\x70e"} = 1;
382 $_badtags{"s\x65\x78"} = 1;
383 map({$_badtags{lc($_)}=1} @Girocco::Config::blocked_tags);
386 # A valid tag must only have [a-zA-Z0-9:.+#_-] characters, must start with a
387 # letter, must not be a noise word, must be more than one character long,
388 # must not be a repeated letter and must be no more than 32 characters long.
389 # However, anything in %_oktags is explicitly allowed even if it otherwise
390 # would violate the rules (except that none of [,\s\\\/] are allowed in tags).
391 # Returns the canonical name for the tag if the tag is valid otherwise undef.
392 sub valid_tag {
393 local $_ = $_[0];
394 return undef unless defined($_) && $_ ne "" && !/[,\s\/\\]/;
395 my $fold = $Girocco::Config::foldtags;
396 if ($fold && !$_canontagscreated) {
397 local $_;
398 %_canontags = ();
399 $_canontags{lc($_)} = $_ foreach sort({$b cmp $a} @_whitetags, @Girocco::Config::allowed_tags);
400 $_canontagscreated = 1;
402 return $_canontags{lc($_)} if $fold && exists($_canontags{lc($_)});
403 return ($fold ? lc($_) : $_) if $_oktags{lc($_)};
404 return undef unless /^[a-zA-Z][a-zA-Z0-9:.+#_-]+$/;
405 return undef if $_badtags{lc($_)};
406 return undef if /^(.)\1+$/;
407 return length($_) <= 32 ? ($fold ? lc($_) : $_) : undef;
410 # If the passed in argument looks like a URL, return only the stuff up through
411 # the host:port part otherwise return the entire argument.
412 sub url_base {
413 my $url = shift || '';
414 # See RFC 3968
415 $url = $1.$2.$3.$4 if $url =~ m,^( [A-Za-z][A-Za-z0-9+.-]*: ) # scheme
416 ( // ) # // separator
417 ((?:[^\@]+\@)?) # optional userinfo
418 ( [^/?#]+ ) # host and port
419 (?:[/?#].*)?$,x; # path and optional query string and/or anchor
420 return $url;
423 # If the passed in argument looks like a URL, return only the stuff following
424 # the host:port part otherwise return the entire argument.
425 # If the optional second argument is true, the returned value will have '/'
426 # appended if it does not already end in '/'.
427 sub url_path {
428 my $url = shift || '';
429 my $add_slash = shift || 0;
430 # See RFC 3968
431 $url = $1 if $url =~ m,^(?: [A-Za-z][A-Za-z0-9+.-]*: ) # scheme
432 (?: // ) # // separator
433 (?: [^\@]+\@ )? # optional userinfo
434 (?: [^/?#]+ ) # host and port
435 ((?:[/?#].*)?)$,x; # path and optional query string and/or anchor
436 $url .= '/' if $add_slash && $url !~ m|/$|;
437 return $url;
440 # If both SERVER_NAME and SERVER_PORT are set pass the argument through url_path
441 # and then prefix it with the appropriate scheme (HTTPS=?on), host and port and
442 # return it. If a something that doesn't look like it could be the start of a
443 # URL path comes back from url_path or SERVER_NAME is a link-local IPv6 address
444 # then just return the argument unchanged.
445 sub url_server {
446 my $url = shift || '';
447 my $path = url_path($url);
448 return $url unless $path eq '' || $path =~ m|^[/?#]|;
449 return $url unless $ENV{'SERVER_NAME'} && $ENV{'SERVER_PORT'} &&
450 $ENV{'SERVER_PORT'} =~ /^[1-9][0-9]{0,4}$/;
451 return $url if $ENV{'SERVER_NAME'} =~ /^[[]?fe80:/i;
452 my $server = $ENV{'SERVER_NAME'};
453 # Deal with Apache bug where IPv6 literal server names do not include
454 # the required surrounding '[' and ']' characters
455 $server = '[' . $server . ']' if $server =~ /:/ && $server !~ /^[[]/;
456 my $ishttps = $ENV{'HTTPS'} && $ENV{'HTTPS'} =~ /^on$/i;
457 my $portnum = 0 + $ENV{'SERVER_PORT'};
458 my $port = '';
459 if (($ishttps && $portnum != 443) || (!$ishttps && $portnum != 80)) {
460 $port = ':' . $portnum;
462 return 'http' . ($ishttps ? 's' : '') . '://' . $server . $port . $path;
465 # Returns the number rounded to the nearest tenths. The ".d" part will be
466 # excluded if it's ".0" unless the optional second argument is true
467 sub _tenths {
468 my $v = shift;
469 my $use0 = shift;
470 $v *= 10;
471 $v += 0.5;
472 $v = int($v);
473 return '' . int($v/10) unless $v % 10 || $use0;
474 return '' . int($v/10) . '.' . ($v%10);
477 # Returns a human-readable size string (e.g. '1.5 MiB') for the value
478 # (in bytes) passed in. Returns '0' for undefined or 0 or not all digits.
479 # Otherwise returns '1 KiB' for < 1024, or else a number rounded to the
480 # nearest tenths of a KiB, MiB or GiB.
481 sub human_size {
482 my $v = shift || 0;
483 return "0" unless $v && $v =~ /^\d+$/;
484 return "1 KiB" unless $v > 1024;
485 $v /= 1024;
486 return _tenths($v) . " KiB" if $v < 1024;
487 $v /= 1024;
488 return _tenths($v) . " MiB" if $v < 1024;
489 $v /= 1024;
490 return _tenths($v) . " GiB";
493 sub _escapeHTML {
494 my $str = shift;
495 $str =~ s/\&/\&amp;/gs;
496 $str =~ s/\</\&lt;/gs;
497 $str =~ s/\>/\&gt;/gs;
498 $str =~ s/\"/\&quot;/gs; #"
499 return $str;
502 # create relative time string from passed in age in seconds
503 sub _rel_age {
504 my $age = shift;
505 my $age_str;
507 if ($age > 60*60*24*365*2) {
508 $age_str = (int $age/60/60/24/365);
509 $age_str .= " years ago";
510 } elsif ($age > 60*60*24*(365/12)*2) {
511 $age_str = int $age/60/60/24/(365/12);
512 $age_str .= " months ago";
513 } elsif ($age > 60*60*24*7*2) {
514 $age_str = int $age/60/60/24/7;
515 $age_str .= " weeks ago";
516 } elsif ($age > 60*60*24*2) {
517 $age_str = int $age/60/60/24;
518 $age_str .= " days ago";
519 } elsif ($age > 60*60*2) {
520 $age_str = int $age/60/60;
521 $age_str .= " hours ago";
522 } elsif ($age > 60*2) {
523 $age_str = int $age/60;
524 $age_str .= " mins ago";
525 } elsif ($age > 2) {
526 $age_str = int $age;
527 $age_str .= " secs ago";
528 } elsif ($age >= 0) {
529 $age_str = "right now";
530 } else {
531 $age_str = "future time";
533 return $age_str;
536 # create relative time string from passed in idle in seconds
537 sub _rel_idle {
538 my $idle_str = _rel_age(shift);
539 $idle_str =~ s/ ago//;
540 $idle_str = "not at all" if $idle_str eq "right now";
541 return $idle_str;
544 sub _strftime {
545 use POSIX qw(strftime);
546 my ($fmt, $secs, $zonesecs) = @_;
547 my ($S,$M,$H,$d,$m,$y) = gmtime($secs + $zonesecs);
548 $zonesecs = int($zonesecs / 60);
549 $fmt =~ s/%z/\$z/g;
550 my $ans = strftime($fmt, $S, $M, $H, $d, $m, $y, -1, -1, -1);
551 my $z;
552 if ($zonesecs < 0) {
553 $z = "-";
554 $zonesecs = -$zonesecs;
555 } else {
556 $z = "+";
558 $z .= sprintf("%02d%02d", int($zonesecs/60), $zonesecs % 60);
559 $ans =~ s/\$z/$z/g;
560 return $ans;
563 # Take a list of project names and produce a nicely formated table that
564 # includes owner links and descriptions. If the list is empty returns ''.
565 # The first argument may be a hash ref that contains options. The following
566 # options are available:
567 # target -- sets the target value of the owner link
568 # emptyok -- if true returns an empty table rather than ''
569 # sizecol -- if true include a human-readable size column
570 # typecol -- if true include type column with hover info
571 # changed -- if true include a changed and idle column
572 sub projects_html_list {
573 my $options = {};
574 if (defined($_[0]) && ref($_[0]) eq 'HASH') {
575 $options = shift;
577 return '' unless @_ || (defined($options->{emptyok}) && $options->{emptyok});
578 require Girocco::Project;
579 my $count = 0;
580 my $target = '';
581 $target = " target=\""._escapeHTML($options->{target})."\""
582 if defined($options->{target});
583 my $withsize = defined($options->{sizecol}) && $options->{sizecol};
584 my $withtype = defined($options->{typecol}) && $options->{typecol};
585 my $withchanged = defined($options->{changed}) && $options->{changed};
586 my $sizehead = '';
587 $sizehead = substr(<<EOT, 0, -1) if $withsize;
588 <th class="sizecol"><span class="hover">Size<span><span class="head" _data="Size"></span
589 /><span class="none" /><br />(</span>Fork size excludes objects borrowed from the parent.<span class="none">)</span></span></span></th
592 my $typehead = '';
593 $typehead = '<th>Type</th>' if $withtype;
594 my $chghead = '';
595 $chghead = substr(<<EOT, 0, -1) if $withchanged;
596 <th><span class="hover">Changed<span><span class="head" _data="Changed"></span
597 /><span class="none" /><br />(</span>The last time a ref change was received by this site.<span class="none">)</span></span></span></th
598 ><th><span class="hover">Idle<span><span class="head" _data="Idle"></span
599 /><span class="none" /><br />(</span>The most recent committer time in <i>refs/heads</i>.<span class="none">)</span></span></span></th
602 my $html = <<EOT;
603 <table class='projectlist'><tr valign="top" align="left"><th>Project</th>$sizehead$typehead$chghead<th class="desc">Description</th></tr>
605 my $trclass = ' class="odd"';
606 foreach (sort({lc($a) cmp lc($b)} @_)) {
607 if (Girocco::Project::does_exist($_, 1)) {
608 my $proj = Girocco::Project->load($_);
609 my $projname = $proj->{name}.".git";
610 my $projdesc = $proj->{desc}||'';
611 utf8::decode($projdesc) if utf8::valid($projdesc);
612 my $sizecol = '';
613 if ($withsize) {
614 my $psize = $proj->{reposizek};
615 $psize = undef unless defined($psize) && $psize =~ /^\d+$/;
616 $psize = 0 if !defined($psize) && $proj->is_empty;
617 if (!defined($psize)) {
618 $psize = 'unknown';
619 } elsif (!$psize) {
620 $psize = 'empty';
621 } else {
622 $psize = human_size($psize * 1024);
623 $psize =~ s/ /\&#160;/g;
625 $sizecol = '<td class="sizecol">'.$psize.'</td>';
627 my $typecol = '';
628 if ($withtype) {
629 if ($proj->{mirror}) {
630 my $url = _escapeHTML($proj->{url});
631 $typecol = substr(<<EOT, 0, -1);
632 <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>
634 } else {
635 my $users = @{$proj->{users}};
636 $users .= ' user';
637 $users .= 's' unless @{$proj->{users}} == 1;
638 my $userlist = join(', ', sort({lc($a) cmp lc($b)} @{$proj->{users}}));
639 my $spncls = length($userlist) > 25 ? '' : ' class="nowrap"';
640 $typecol = $userlist ? substr(<<EOT, 0, -1) : substr(<<EOT, 0, -1);
641 <td class="type"><span class="hover">$users<span$spncls><br class="none" />$userlist</span></span></td>
643 <td class="type">$users</td>
647 my $changecol = '';
648 if ($withchanged) {
649 my $rel = '';
650 my $changetime = $proj->{lastchange};
651 if ($changetime) {
652 my ($ts, $tz);
653 $ts = parse_rfc2822_date($changetime, \$tz);
654 my $ct = _strftime("%Y-%m-%d %T %z", $ts, $tz);
655 $rel = "<span class=\"hover\">" .
656 _rel_age(time - $ts) .
657 "<span class=\"nowrap\"><span class=\"before\" _data=\"$changetime\"></span><span class=\"none\"><br />$ct</span></span></span>";
658 } else {
659 $rel = "no commits";
661 $changecol = substr(<<EOT, 0, -1);
662 <td class="change">$rel</td>
664 my $idletime = $proj->{lastactivity};
665 my ($idlesecs, $tz);
666 $idlesecs = parse_any_date($idletime, \$tz) if $idletime;
667 if ($idlesecs) {
668 my $idle2822 = _strftime("%a, %d %b %Y %T %z", $idlesecs, $tz);
669 my $ct = _strftime("%Y-%m-%d %T %z", $idlesecs, $tz);
670 $rel = "<span class=\"hover\">" .
671 _rel_idle(time - $idlesecs) .
672 "<span class=\"nowrap\"><span class=\"before\" _data=\"$idle2822\"></span><span class=\"none\"><br />$ct</span></span></span>";
673 } else {
674 $rel = "no commits";
676 $changecol .= substr(<<EOT, 0, -1);
677 <td class="idle">$rel</td>
680 $html .= <<EOT;
681 <tr valign="top"$trclass><td><a href="@{[url_path($Girocco::Config::gitweburl)]}/$projname"$target
682 >@{[_escapeHTML($projname)]}</td>$sizecol$typecol$changecol<td>@{[_escapeHTML($projdesc)]}</td></tr>
684 $trclass = $trclass ? '' : ' class="odd"';
685 ++$count;
688 $html .= <<EOT;
689 </table>
691 return ($count || (defined($options->{emptyok}) && $options->{emptyok})) ? $html : '';
694 my %_month_names;
695 BEGIN {
696 %_month_names = (
697 jan => 0, feb => 1, mar => 2, apr => 3, may => 4, jun => 5,
698 jul => 6, aug => 7, sep => 8, oct => 9, nov => 10, dec => 11
702 # Should be in "date '+%a, %d %b %Y %T %z'" format as saved to lastgc, lastrefresh and lastchange
703 # The leading "%a, " is optional, returns undef if unrecognized date. This is also known as
704 # RFC 2822 date format and git's '%cD', '%aD' and --date=rfc2822 format.
705 # If the second argument is a SCALAR ref, its value will be set to the TZ offset in seconds
706 sub parse_rfc2822_date {
707 my $dstr = shift || '';
708 my $tzoff = shift || '';
709 $dstr = $1 if $dstr =~/^[^\s]+,\s*(.*)$/;
710 return undef unless $dstr =~
711 /^\s*(\d{1,2})\s+([A-Za-z]{3})\s+(\d{4})\s+(\d{1,2}):(\d{2}):(\d{2})\s+([+-]\d{4})\s*$/;
712 my ($d,$b,$Y,$H,$M,$S,$z) = ($1,$2,$3,$4,$5,$6,$7);
713 my $m = $_month_names{lc($b)};
714 return undef unless defined($m);
715 my $seconds = timegm(0+$S, 0+$M, 0+$H, 0+$d, 0+$m, $Y-1900);
716 my $offset = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
717 $offset = -$offset if substr($z,0,1) eq '-';
718 $$tzoff = $offset if ref($tzoff) eq 'SCALAR';
719 return $seconds - $offset;
722 # Will parse any supported date format. Actually there are three formats
723 # currently supported:
724 # 1. RFC 2822 (uses parse_rfc2822_date)
725 # 2. RFC 3339 / ISO 8601 (T may be ' ' or '_', 'Z' is optional or may be 'UTC', ':' optional in TZ)
726 # 3. Same as #2 except no colons or hyphens allowed and hours MUST be 2 digits
727 # 4. unix seconds since epoch with optional +/- trailing TZ (may not have a ':')
728 # Returns undef if unsupported date.
729 # If the second argument is a SCALAR ref, its value will be set to the TZ offset in seconds
730 sub parse_any_date {
731 my $dstr = shift || '';
732 my $tzoff = shift || '';
733 if ($dstr =~ /^\s*([-+]?\d+)(?:\s+([-+]\d{4}))?\s*$/) {
734 # Unix timestamp
735 my $ts = 0 + $1;
736 my $off = 0;
737 if ($2) {
738 my $z = $2;
739 $off = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
740 $off = -$off if substr($z,0,1) eq '-';
742 $$tzoff = $off if ref($tzoff) eq 'SCALAR';
743 return $ts;
745 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*$/ ||
746 $dstr =~ /^\s*(\d{4})(\d{2})(\d{2})[Tt _](\d{2})(\d{2})(\d{2})(?:[ _]?([Zz]|[Uu][Tt][Cc]|(?:[-+]\d{2}\d{2})))?\s*$/) {
747 my ($Y,$m,$d,$H,$M,$S,$z) = ($1,$2,$3,$4,$5,$6,$7||'');
748 my $seconds = timegm(0+$S, 0+$M, 0+$H, 0+$d, $m-1, $Y-1900);
749 defined($z) && $z ne '' or $z = 'Z';
750 $z = uc($z);
751 $z =~ s/://;
752 substr($z,1,0) = '0' if length($z) == 4;
753 my $off = 0;
754 if ($z ne 'Z' && $z ne 'UTC') {
755 $off = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
756 $off = -$off if substr($z,0,1) eq '-';
758 $$tzoff = $off if ref($tzoff) eq 'SCALAR';
759 return $seconds - $off;
761 return parse_rfc2822_date($dstr, $tzoff);
764 # Input is a number such as a minute interval
765 # Return value is a random number between the input and 1.25*input
766 # This can be used to randomize the update and gc operations a bit to avoid
767 # having them all end up all clustered together
768 sub rand_adjust {
769 my $input = shift || 0;
770 return $input unless $input;
771 return $input + int(rand(0.25 * $input));
774 # Open a pipe to a new sendmail process. The '-i' option is always passed to
775 # the new process followed by any addtional arguments passed in. Note that
776 # the sendmail process is only expected to understand the '-i', '-t' and '-f'
777 # options. Using any other options via this function is not guaranteed to work.
778 # A list of recipients may follow the options. Combining a list of recipients
779 # with the '-t' option is not recommended.
780 sub sendmail_pipe {
781 return undef unless @_;
782 die "\$Girocco::Config::sendmail_bin is unset or not executable!\n"
783 unless $Girocco::Config::sendmail_bin && -x $Girocco::Config::sendmail_bin;
784 my $result = open(my $pipe, '|-', $Girocco::Config::sendmail_bin, '-i', @_);
785 return $result ? $pipe : undef;
788 # Open a pipe that works similarly to a mailer such as /usr/bin/mail in that
789 # if the first argument is '-s', a subject line will be automatically added
790 # (using the second argument as the subject). Any remaining arguments are
791 # expected to be recipient addresses that will be added to an explicit To:
792 # line as well as passed on to sendmail_pipe. In addition an
793 # "Auto-Submitted: auto-generated" header is always added as well as a suitable
794 # "From:" header.
795 sub mailer_pipe {
796 my $subject = undef;
797 if (@_ >= 2 && $_[0] eq '-s') {
798 shift;
799 $subject = shift;
801 my $tolist = join(", ", @_);
802 unshift(@_, '-f', $Girocco::Config::sender) if $Girocco::Config::sender;
803 my $pipe = sendmail_pipe(@_);
804 if ($pipe) {
805 print $pipe "From: \"$Girocco::Config::name\" ",
806 "($Girocco::Config::title) ",
807 "<$Girocco::Config::admin>\n";
808 print $pipe "To: $tolist\n";
809 print $pipe "Subject: $subject\n" if defined($subject);
810 print $pipe "MIME-Version: 1.0\n";
811 print $pipe "Content-Type: text/plain; charset=utf-8\n";
812 print $pipe "Content-Transfer-Encoding: 8bit\n";
813 print $pipe "X-Girocco: $Girocco::Config::gitweburl\n"
814 unless $Girocco::Config::suppress_x_girocco;
815 print $pipe "Auto-Submitted: auto-generated\n";
816 print $pipe "\n";
818 return $pipe;
821 sub _goodval {
822 my $val = shift;
823 return undef unless defined($val);
824 $val =~ s/[\r\n]+$//s;
825 return undef unless $val =~ /^\d+$/;
826 $val = 0 + $val;
827 return undef unless $val >= 1;
828 return $val;
831 # Returns the number of "online" cpus or undef if undetermined
832 sub online_cpus {
833 my @confcpus = $^O eq "linux" ?
834 qw(_NPROCESSORS_ONLN NPROCESSORS_ONLN) :
835 qw(NPROCESSORS_ONLN _NPROCESSORS_ONLN) ;
836 my $cpus = _goodval(get_cmd('getconf', $confcpus[0]));
837 return $cpus if $cpus;
838 $cpus = _goodval(get_cmd('getconf', $confcpus[1]));
839 return $cpus if $cpus;
840 if ($^O ne "linux") {
841 my @sysctls = qw(hw.ncpu);
842 unshift(@sysctls, qw(hw.availcpu)) if $^O eq "darwin";
843 foreach my $mib (@sysctls) {
844 $cpus = _goodval(get_cmd('sysctl', '-n', $mib));
845 return $cpus if $cpus;
848 return undef;
851 # Returns the system page size in bytes or undef if undetermined
852 # This should never fail on a POSIX system
853 sub sys_pagesize {
854 use POSIX ":unistd_h";
855 my $pagesize = sysconf(_SC_PAGESIZE);
856 return undef unless defined($pagesize) && $pagesize =~ /^\d+$/;
857 $pagesize = 0 + $pagesize;
858 return undef unless $pagesize >= 256;
859 return $pagesize;
862 # Returns the amount of available physical memory in bytes
863 # This may differ from the actual amount of physical memory installed
864 # Returns undef if this cannot be determined
865 sub sys_memsize {
866 my $pagesize = sys_pagesize;
867 if ($pagesize && $^O eq "linux") {
868 my $pages = _goodval(get_cmd('getconf', '_PHYS_PAGES'));
869 return $pagesize * $pages if $pages;
871 if ($^O ne "linux") {
872 my @sysctls = qw(hw.physmem64);
873 unshift(@sysctls, qw(hw.memsize)) if $^O eq "darwin";
874 foreach my $mib (@sysctls) {
875 my $memsize = _goodval(get_cmd('sysctl', '-n', $mib));
876 return $memsize if $memsize;
878 my $memsize32 = _goodval(get_cmd('sysctl', '-n', 'hw.physmem'));
879 return $memsize32 if $memsize32 && $memsize32 <= 2147483647;
880 if ($pagesize) {
881 my $pages = _goodval(get_cmd('sysctl', '-n', 'hw.availpages'));
882 return $pagesize * $pages if $pages;
884 return 2147483647 + 1 if $memsize32;
886 return undef;
889 sub _get_max_conf_suffixed_size {
890 my $conf = shift;
891 return undef unless defined $conf && $conf =~ /^(\d+)([kKmMgG]?)$/;
892 my ($val, $suffix) = (0+$1, lc($2));
893 $val *= 1024 if $suffix eq 'k';
894 $val *= 1024 * 1024 if $suffix eq 'm';
895 $val *= 1024 * 1024 * 1024 if $suffix eq 'g';
896 return $val;
899 sub _make_suffixed_size {
900 my $size = shift;
901 return $size if $size % 1024;
902 $size /= 1024;
903 return "${size}k" if $size % 1024;
904 $size /= 1024;
905 return "${size}m" if $size % 1024;
906 $size /= 1024;
907 return "${size}g";
910 # Return the value to pass to --window-memory= for git repack
911 # If the system memory or number of CPUs cannot be determined, returns "1g"
912 # Otherwise returns one third the available memory divided by the number of CPUs
913 # but never more than 1 gigabyte or max_gc_window_memory_size.
914 sub calc_windowmemory {
915 my $cpus = online_cpus;
916 my $memsize = sys_memsize;
917 my $max = 1024 * 1024 * 1024;
918 if ($cpus && $memsize) {
919 $max = int($memsize / 3 / $cpus);
920 $max = 1024 * 1024 * 1024 if $max >= 1024 * 1024 * 1024;
922 my $maxconf = _get_max_conf_suffixed_size($Girocco::Config::max_gc_window_memory_size);
923 $max = $maxconf if defined($maxconf) && $maxconf && $max > $maxconf;
924 return _make_suffixed_size($max);
927 # Return the value to set as core.bigFileThreshold for git repack
928 # If the system memory cannot be determined, returns "256m"
929 # Otherwise returns the available memory divided by 16
930 # but never more than 512 megabytes or max_gc_big_file_threshold_size.
931 sub calc_bigfilethreshold {
932 my $memsize = sys_memsize;
933 my $max = 256 * 1024 * 1024;
934 if ($memsize) {
935 $max = int($memsize / 16);
936 $max = 512 * 1024 * 1024 if $max >= 512 * 1024 * 1024;
938 my $maxconf = _get_max_conf_suffixed_size($Girocco::Config::max_gc_big_file_threshold_size);
939 $max = $maxconf if defined($maxconf) && $maxconf && $max > $maxconf;
940 return _make_suffixed_size($max);
943 # Return the value to use when deciding whether or not to re-calculate object deltas
944 # If there are no more than this many objects then deltas will be recomputed in
945 # order to create more efficient pack files. The new_delta_threshold value
946 # is constrained to be at least 1000 * cpu cores and no more than 100000.
947 # The default is sys_memsize rounded up to the nearest multiple of 256 MB and
948 # then 5000 per 256 MB or 50000 if we cannot determine memory size but never
949 # more than 100000 or less than 1000 * cpu cores.
950 sub calc_redeltathreshold {
951 my $cpus = online_cpus || 1;
952 if (defined($Girocco::Config::new_delta_threshold) &&
953 $Girocco::Config::new_delta_threshold =~ /^\d+/) {
954 my $ndt = 0 + $Girocco::Config::new_delta_threshold;
955 if ($ndt >= $cpus * 1000) {
956 return $ndt <= 100000 ? $ndt : 100000;
959 my $calcval = 50000;
960 my $memsize = sys_memsize;
961 if ($memsize) {
962 my $quantum = 256 * 1024 * 1024;
963 $calcval = 5000 * int(($memsize + ($quantum - 1)) / $quantum);
964 $calcval = 1000 * $cpus if $calcval < 1000 * $cpus;
965 $calcval = 100000 if $calcval > 100000;
967 return $calcval;
970 # $1 => thing to test
971 # $2 => optional directory, if given and -e "$2/$1$3", then return false
972 # $3 => optional, defaults to ''
973 sub has_reserved_suffix {
974 no warnings; # avoid silly 'unsuccessful stat on filename with \n' warning
975 my ($name, $dir, $ext) = @_;
976 $ext = '' unless defined $ext;
977 return 0 unless defined $name && $name =~ /\.([^.]+)$/;
978 return 0 unless exists $Girocco::Config::reserved_suffixes{lc($1)};
979 return 0 if defined $dir && -e "$dir/$name$ext";
980 return 1;
983 # mostly undoes effect of `use CGI::Carp qw(fatalsToBrowser);`
984 # mostly undoes effect of `use CGI::Carp qw(warningsToBrowser);`
985 sub noFatalsToBrowser {
986 delete $SIG{__DIE__};
987 delete $SIG{__WARN__};
988 undef *CORE::GLOBAL::die;
989 *CORE::GLOBAL::die = sub {
990 no warnings;
991 my $ec = $! || ($? >> 8) || 255;
992 my (undef, $fn, $li) = caller(0);
993 my $loc = " at " . $fn . " line " . $li . ".\n";
994 my $msg = "";
995 $msg = join("", @_) if @_;
996 $msg = "Died" if $msg eq "";
997 $msg .= $loc unless $msg =~ /\n$/;
998 die $msg if $^S;
999 printf STDERR "%s", $msg;
1000 exit($ec);
1002 undef *CORE::GLOBAL::warn;
1003 *CORE::GLOBAL::warn = sub {
1004 no warnings;
1005 my (undef, $fn, $li) = caller(0);
1006 my $loc = " at " . $fn . " line " . $li . ".\n";
1007 my $msg = "";
1008 $msg = join("", @_) if @_;
1009 $msg = "Warning: something's wrong" if $msg eq "";
1010 $msg .= $loc unless $msg =~ /\n$/;
1011 printf STDERR "%s", $msg;
1015 # mimics Git's symref reading but only for HEAD
1016 # returns undef on failure otherwise an string that is
1017 # either an all-hex (lowercase) value or starts with "refs/"
1018 sub read_HEAD_ref {
1019 my $headpath = $_[0] . "/HEAD";
1020 if (-l $headpath) {
1021 my $rl = readlink($headpath);
1022 return defined($rl) && $rl =~ m,^refs/[^\x00-\x1f \x7f~^:\\*?[]+$, ? $rl : undef;
1024 open my $fd, '<', $headpath or return undef;
1025 my $hv;
1027 local $/ = undef;
1028 $hv = <$fd>;
1030 close $fd;
1031 defined($hv) or return undef;
1032 chomp $hv;
1033 $hv =~ m,^ref:\s*(refs/[^\x00-\x1f \x7f~^:\\*?[]+)$, and return $1;
1034 $hv =~ m/^[0-9a-fA-F]{40,}$/ and return lc($hv);
1035 return undef;
1038 # same as read_HEAD_ref but returns undef
1039 # unless the result starts with "refs/"
1040 sub read_HEAD_symref {
1041 my $hv = read_HEAD_ref(@_);
1042 return defined($hv) && $hv =~ m,^refs/., ? $hv : undef;
1045 my $cf_unesc;
1046 BEGIN {
1047 my %escvals = (
1048 b => "\b",
1049 t => "\t",
1050 n => "\n",
1051 '"' => '"',
1052 '\\' => '\\'
1054 $cf_unesc = sub {
1055 $_[0] =~ s/\\([btn\042\\])/$escvals{$1}/g;
1056 $_[0];
1060 # mimics Git's config.c git_parse_source function behavior
1061 # returns array of arrayref of key and value
1062 # except that valueless booleans have a value of undef
1063 sub read_config_file {
1064 local $_;
1065 my ($fn, $warn) = @_;
1066 my $li = 0;
1067 my $section = "";
1068 my @vals = ();
1069 open my $fh, '<', $fn or
1070 $warn && warn("could not open \"$fn\": $!\n"), return(undef);
1071 binmode($fh);
1072 my $bad = sub {
1073 close $fh;
1074 warn "bad config line $li in file $fn\n" if $warn;
1075 return undef;
1077 while (<$fh>) {
1078 ++$li;
1079 s/(?:\r\n|\n)$//;
1080 $_ = to_utf8($_);
1081 s/^\x{feff}// if $li == 1;
1082 utf8::encode($_);
1083 if (/^\s*\[/gc) {
1084 if (/\G([.a-zA-Z0-9-]+)\]/gc) {
1085 $section = lc($1) . ".";
1086 } elsif (/\G([.a-zA-Z0-9-]*)\s+"((?:[^\042\\\n]|\\.)*)"\]/gc) {
1087 $section = lc($1) . "." .
1088 &{sub{my $x=shift; $x =~ s/\\(.)/$1/g; $x}}($2) . ".";
1089 } else {
1090 return &$bad;
1093 /\G\s+/gc;
1094 next if /\G(?:[;#]|$)/;
1095 if (/\G([a-zA-Z][a-zA-Z0-9-]*)[ \t]*/gc) {
1096 my $k = $section . lc($1);
1097 my $v;
1098 if (/\G$/) {
1099 $v = undef;
1100 } elsif (/\G=\s*/gc) {
1101 $v = "";
1102 my $qt = 0;
1104 if (/\G$/) {
1105 last if !$qt;
1106 return &$bad;
1108 if (!$qt && /\G((?:[^"\\\n;#]|\\[btn"\\])+)/gc) {
1109 my $a = $1;
1110 if (/\G[;#]/) {
1111 $_ = "";
1112 $a =~ s/\s+$//;
1114 $a =~ s/\s/ /g;
1115 $v .= &$cf_unesc($a);
1116 } elsif ($qt && /\G((?:[^"\\\n]|\\[btn"\\])+)/gc) {
1117 my $a = $1;
1118 $v .= &$cf_unesc($a);
1119 } elsif (/\G\042/gc) {
1120 $qt = !$qt;
1121 } elsif (!$qt && /\G[;#]/gc) {
1122 $_ = "";
1123 } elsif (/\G\\$/) {
1124 $_ = <$fh>;
1125 if (defined($_)) {
1126 ++$li;
1127 s/(?:\r\n|\n)$//;
1128 $_ = to_utf8($_, 1);
1129 /^\s+/gc unless $v ne "" || $qt;
1130 } else {
1131 $_ = "";
1133 } else {
1134 return &$bad;
1136 redo;
1138 } else {
1139 return &$bad;
1141 push(@vals, [$k, $v]);
1142 } else {
1143 return &$bad;
1146 close $fh;
1147 return \@vals;
1150 # Same as read_config_file except that a hashref is returned and
1151 # subsequent same-key-name values replace earlier ones.
1152 # Also valueless booleans are given the value 1
1153 sub read_config_file_hash {
1154 my $result = read_config_file(@_);
1155 return undef unless defined($result);
1156 my %config = map {($$_[0], defined($$_[1])?$$_[1]:1)} @$result;
1157 return \%config;
1160 # similar to Git's test except that GIT_OBJECT_DIRECTORY is ignored
1161 sub is_git_dir {
1162 my $gd = shift;
1163 defined($gd) && $gd ne "" && -d $gd or return undef;
1164 -d "$gd/objects" && -x "$gd/objects" or return 0;
1165 -d "$gd/refs" && -x "$gd/refs" or return 0;
1166 if (-l "$gd/HEAD") {
1167 my $rl = readlink("$gd/HEAD");
1168 defined($rl) && $rl =~ m,^refs/., or return 0;
1169 -e "$gd/HEAD" or return 1;
1171 open my $fd, '<', "$gd/HEAD" or return 0;
1172 my $hv;
1174 local $/;
1175 $hv = <$fd>;
1177 close $fd;
1178 defined $hv or return 0;
1179 chomp $hv;
1180 $hv =~ m,^ref:\s*refs/., and return 1;
1181 return $hv =~ /^[0-9a-f]{40}/;
1184 # Returns 0 for false, 1 for true, undef for unrecognized or undef
1185 # Unless the optional second argument is true in which case undef returns 1
1186 sub git_bool {
1187 defined($_[0]) or return $_[1] ? 1 : undef;
1188 my $v = lc($_[0]);
1189 return 0 if $v eq 'false' || $v eq 'off' || $v eq 'no' || $v eq '' || $v =~ /^[-+]?0+$/;
1190 return 1 if $v eq 'true' || $v eq 'on' || $v eq 'yes' || $v =~ /^[-+]?0*[1-9][0-9]*$/;
1191 return undef;
1194 # Returns a PATH properly prefixed which guarantees that Git is found and the
1195 # basedir/bin utilities are found as intended. $ENV{PATH} is LEFT UNCHANGED!
1196 # Caller is responsible for assigning result to $ENV{PATH} or otherwise
1197 # arranging for it to be used. If $ENV{PATH} already has the proper prefix
1198 # then it's returned as-is (making this function idempotent).
1199 # Will die if it cannot determine a suitable full PATH.
1200 # Result is cached so all calls after the first are practically free.
1201 my $var_git_exec_path;
1202 sub util_path {
1203 if (!defined($var_git_exec_path)) {
1204 defined($Girocco::Config::basedir) && $Girocco::Config::basedir ne "" &&
1205 -d $Girocco::Config::basedir && -r _ && -x _ or
1206 die "invalid \$Girocco::Config::basedir setting: $Girocco::Config::basedir\n";
1207 my $varsfile = $Girocco::Config::basedir . "/shlib_vars.sh";
1208 if (-f $varsfile && -r _) {
1209 my $vars;
1210 if (open $vars, '<', $varsfile) {
1211 # last value for var_git_exec_path wins
1212 while (<$vars>) {
1213 chomp;
1214 substr($_, 0, 19) eq "var_git_exec_path=\"" or next;
1215 substr($_, -1, 1) eq "\"" or next;
1216 my $xd = substr($_, 19, -1);
1217 $var_git_exec_path = $xd if -d $xd && -r _ && -x _;
1219 close $vars;
1222 if (!defined($var_git_exec_path)) {
1223 my $xd = get_git("--exec-path");
1224 $var_git_exec_path = $xd if defined($xd) &&
1225 (chomp $xd, $xd) ne "" && -d $xd && -r _ && -x _;
1227 defined($var_git_exec_path) or
1228 die "could not determine \$(git --exec-path) value\n"
1230 my $prefix = "$var_git_exec_path:$Girocco::Config::basedir/bin:";
1231 if (substr($ENV{PATH}, 0, length($prefix)) eq $prefix) {
1232 return $ENV{PATH};
1233 } else {
1234 return $prefix . $ENV{PATH};
1238 # Note that Perl performs a "shellish" test in the Perl_do_exec3 function from doio.c,
1239 # but it has slightly different semantics in that whitespace does not automatically
1240 # make something "shellish". The semantics used here more closely match Git's
1241 # semantics so that Girocco will provide an interpretation more similar to Git's.
1242 sub is_shellish {
1243 return unless defined(local $_ = shift);
1244 return 1 if m#[][\$&*(){}'";:=\\|?<>~`\#\s]#; # contains metacharacters
1245 return 0; # probably not shellish