10 use base
qw(Exporter);
11 our @EXPORT = qw(scrypt jailed_file
13 filedb_atomic_append filedb_atomic_edit filedb_grep
14 filedb_atomic_grep valid_email valid_email_multi
15 valid_repo_url valid_web_url url_path
16 projects_html_list parse_date);
22 crypt($pwd||'', join ('', ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]));
28 $Girocco::Config
::chroot."/$filename";
37 use Fcntl
qw(O_WRONLY O_CREAT O_EXCL);
39 my $handle = new IO
::Handle
;
41 unless (sysopen($handle, $path, O_WRONLY
|O_CREAT
|O_EXCL
)) {
43 while (not sysopen($handle, $path, O_WRONLY
|O_CREAT
|O_EXCL
)) {
44 ($! == EEXIST
) or die "$path open failed: $!";
45 ($cnt++ < 16) or die "$path open failed: cannot open lockfile";
49 # XXX: filedb-specific
50 chmod 0664, $path or die "$path g+w failed: $!";
56 my ($path, $noreplace) = @_;
59 rename "$path.lock", $path or die "$path unlock failed: $!";
61 unlink "$path.lock" or die "$path unlock failed: $!";
65 sub filedb_atomic_append
{
66 my ($file, $line) = @_;
69 open my $src, '<', $file or die "$file open for reading failed: $!";
70 my $dst = lock_file
($file);
73 my $aid = (split /:/)[2];
74 $id = $aid + 1 if ($aid >= $id);
76 print $dst $_ or die "$file(l) write failed: $!";
80 print $dst "$line\n" or die "$file(l) write failed: $!";
82 close $dst or die "$file(l) close failed: $!";
90 sub filedb_atomic_edit
{
93 open my $src, '<', $file or die "$file open for reading failed: $!";
94 my $dst = lock_file
($file);
97 print $dst $fn->($_) or die "$file(l) write failed: $!";
100 close $dst or die "$file(l) close failed: $!";
106 sub filedb_atomic_grep
{
107 my ($file, $fn) = @_;
110 open my $src, '<', $file or die "$file open for reading failed: $!";
111 my $dst = lock_file
($file);
114 my $result = $fn->($_);
115 push(@results, $result) if $result;
118 close $dst or die "$file(l) close failed: $!";
121 unlock_file
($file, 1);
126 my ($file, $fn) = @_;
129 open my $src, '<', $file or die "$file open for reading failed: $!";
132 my $result = $fn->($_);
133 push(@results, $result) if $result;
143 /^[a-zA-Z0-9+._-]+@[a-zA-Z0-9.-]+$/;
145 sub valid_email_multi
{
147 # More relaxed, we just want to avoid too dangerous characters.
148 /^[a-zA-Z0-9+._, @-]+$/;
152 /^https?:\/\
/[a-zA-Z0-9.:-]+(\/[_\
%a-zA
-Z0
-9.\
/~:?&=;-]*)?(#[a-zA-Z0-9._-]+)?$/;
156 /^(https?|git|svn(\+http)?|svn(\+https)?|darcs|bzr):\/\
/[a-zA-Z0-9.:-]+(\/[_\
%a-zA
-Z0
-9.\
/~-]*)?$/;
159 # If the passed in argument looks like a URL, return only the stuff following
160 # the host:port part otherwise return the entire argument.
162 my $url = shift || '';
164 $url = $1 if $url =~ m
,^(?
: [A
-Za
-z
][A
-Za
-z0
-9+.-]*: ) # scheme
165 (?
: // ) # // separator
166 (?
: [^\@
]+\@
)?
# optional userinfo
167 (?
: [^/?
#]+ ) # host and port
168 ((?
:[/?#].*)?)$,x; # path and optional query string and/or anchor
174 $str =~ s/\&/\&/gs;
175 $str =~ s/\</\</gs;
176 $str =~ s/\>/\>/gs;
177 $str =~ s/\"/\"/gs; #"
181 # create relative time string from passed in age in seconds
186 if ($age > 60*60*24*365*2) {
187 $age_str = (int $age/60/60/24/365);
188 $age_str .= " years ago";
189 } elsif ($age > 60*60*24*(365/12)*2) {
190 $age_str = int $age/60/60/24/(365/12);
191 $age_str .= " months ago";
192 } elsif ($age > 60*60*24*7*2) {
193 $age_str = int $age/60/60/24/7;
194 $age_str .= " weeks ago";
195 } elsif ($age > 60*60*24*2) {
196 $age_str = int $age/60/60/24;
197 $age_str .= " days ago";
198 } elsif ($age > 60*60*2) {
199 $age_str = int $age/60/60;
200 $age_str .= " hours ago";
201 } elsif ($age > 60*2) {
202 $age_str = int $age/60;
203 $age_str .= " mins ago";
206 $age_str .= " secs ago";
207 } elsif ($age >= 0) {
208 $age_str = "right now";
210 $age_str = "future time";
215 # Take a list of project names and produce a nicely formated table that
216 # includes owner links and descriptions. If the list is empty returns ''.
217 # The first argument may be a hash ref that contains options. The following
218 # options are available:
219 # target -- sets the target value of the owner link
220 # emptyok -- if true returns an empty table rather than ''
221 # typecol -- if true include type column with hover info
222 # changed -- if true include a changed column
223 sub projects_html_list
{
225 if (defined($_[0]) && ref($_[0]) eq 'HASH') {
228 return '' unless @_ || (defined($options->{emptyok
}) && $options->{emptyok
});
229 require Girocco
::Project
;
232 $target = " target=\""._escapeHTML
($options->{target
})."\""
233 if defined($options->{target
});
234 my $withtype = defined($options->{typecol
}) && $options->{typecol
};
235 my $withchanged = defined($options->{changed
}) && $options->{changed
};
237 $typehead = '<th>Type</th>' if $withtype;
239 $chghead = '<th>Changed</th>' if $withchanged;
241 <table class='projectlist'><tr><th>Project</th>$typehead$chghead<th class="desc">Description</th></tr>
243 my $trclass = ' class="odd"';
244 foreach (sort({lc($a) cmp lc($b)} @_)) {
245 if (Girocco
::Project
::does_exist
($_)) {
246 my $proj = Girocco
::Project
->load($_);
247 my $projname = $proj->{name
}.".git";
248 my $projdesc = $proj->{desc
}||'';
249 utf8
::decode
($projdesc) if utf8
::valid
($projdesc);
252 if ($proj->{mirror
}) {
253 $typecol = substr(<<EOT, 0, -1);
254 <td class="type"><span class="hover">mirror<span class="nowrap">@{[_escapeHTML($proj->{url})]}</span></span></td>
257 my $users = @
{$proj->{users
}};
259 $users .= 's' unless @
{$proj->{users
}} == 1;
260 my $userlist = join(', ', sort({lc($a) cmp lc($b)} @
{$proj->{users
}}));
261 my $spncls = length($userlist) > 25 ?
'' : ' class="nowrap"';
262 $typecol = $userlist ?
substr(<<EOT, 0, -1) : substr(<<EOT, 0, -1);
263 <td
class="type"><span
class="hover">$users<span
$spncls>$userlist</span></span
></td
>
265 <td
class="type">$users</td
>
272 my $changetime = $proj->{lastchange
};
274 $rel = "<span class=\"hover\">" .
275 _rel_age
(time - parse_date
($changetime)) .
276 "<span class=\"nowrap\">$changetime</span></span>";
280 $changecol = substr(<<EOT, 0, -1);
281 <td class="change">$rel</td>
285 <tr$trclass><td><a href="@{[url_path($Girocco::Config::gitweburl)]}/$projname"$target
286 >@{[_escapeHTML($projname)]}</td>$typecol$changecol<td>@{[_escapeHTML($projdesc)]}</td></tr>
288 $trclass = $trclass ?
'' : ' class="odd"';
295 return ($count || (defined($options->{emptyok
}) && $options->{emptyok
})) ?
$html : '';
301 jan
=> 0, feb
=> 1, mar
=> 2, apr
=> 3, may
=> 4, jun
=> 5,
302 jul
=> 6, aug
=> 7, sep
=> 8, oct => 9, nov
=> 10, dec
=> 11
306 # Should be in "date '+%a, %d %b %Y %T %z'" format as saved to lastgc, lastrefresh and lastchange
307 # The leading "%a, " is optional, returns undef if unrecognized date
309 my $dstr = shift || '';
310 $dstr = $1 if $dstr =~/^[^\s]+,\s*(.*)$/;
311 return undef unless $dstr =~
312 /^\s*(\d{1,2})\s+([A-Za-z]{3})\s+(\d{4})\s+(\d{1,2}):(\d{2}):(\d{2})\s+([+-]\d{4})/;
313 my ($d,$b,$Y,$H,$M,$S,$z) = ($1,$2,$3,$4,$5,$6,$7);
314 my $m = $_month_names{lc($b)};
315 return undef unless defined($m);
316 my $seconds = timegm
(0+$S, 0+$M, 0+$H, 0+$d, 0+$m, $Y-1900);
317 my $offset = 60 * (60 * (0+substr($z,1,2)) + (0+substr($z,3,2)));
318 $offset = -$offset if substr($z,0,1) eq '-';
319 return $seconds - $offset;