Add support for mirroring bzr repos
[girocco/testingthisout.git] / Girocco / Util.pm
blob3f0b8032e2c0feae650957375cf1ee14c11b95b7
1 package Girocco::Util;
3 use strict;
4 use warnings;
6 use Girocco::Config;
8 BEGIN {
9 use base qw(Exporter);
10 our @EXPORT = qw(scrypt jailed_file
11 lock_file unlock_file
12 filedb_atomic_append filedb_atomic_edit
13 valid_email valid_email_multi
14 valid_repo_url valid_web_url);
18 sub scrypt {
19 my ($pwd) = @_;
20 crypt($pwd, join ('', ('.', '/', 2..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]));
23 sub jailed_file {
24 my ($filename) = @_;
25 $Girocco::Config::chroot."/$filename";
28 sub lock_file {
29 my ($path) = @_;
31 $path .= '.lock';
33 use Errno qw(EEXIST);
34 use Fcntl qw(O_WRONLY O_CREAT O_EXCL);
35 use IO::Handle;
36 my $handle = new IO::Handle;
38 unless (sysopen($handle, $path, O_WRONLY|O_CREAT|O_EXCL)) {
39 my $cnt = 0;
40 while (not sysopen($handle, $path, O_WRONLY|O_CREAT|O_EXCL)) {
41 ($! == EEXIST) or die "$path open failed: $!";
42 ($cnt++ < 16) or die "$path open failed: cannot open lockfile";
43 sleep(1);
46 # XXX: filedb-specific
47 chmod 0664, $path or die "$path g+w failed: $!";
49 $handle;
52 sub unlock_file {
53 my ($path) = @_;
55 rename "$path.lock", $path or die "$path unlock failed: $!";
58 sub filedb_atomic_append {
59 my ($file, $line) = @_;
60 my $id = 65536;
62 open my $src, $file or die "$file open for reading failed: $!";
63 my $dst = lock_file($file);
65 while (<$src>) {
66 my $aid = (split /:/)[2];
67 $id = $aid + 1 if ($aid >= $id);
69 print $dst $_ or die "$file(l) write failed: $!";
72 $line =~ s/\\i/$id/g;
73 print $dst "$line\n" or die "$file(l) write failed: $!";
75 close $dst or die "$file(l) close failed: $!";
76 close $src;
78 unlock_file($file);
80 $id;
83 sub filedb_atomic_edit {
84 my ($file, $fn) = @_;
86 open my $src, $file or die "$file open for reading failed: $!";
87 my $dst = lock_file($file);
89 while (<$src>) {
90 print $dst $fn->($_) or die "$file(l) write failed: $!";
93 close $dst or die "$file(l) close failed: $!";
94 close $src;
96 unlock_file($file);
99 sub valid_email {
100 $_ = $_[0];
101 /^[a-zA-Z0-9+._-]+@[a-zA-Z0-9-.]+$/;
103 sub valid_email_multi {
104 $_ = $_[0];
105 # More relaxed, we just want to avoid too dangerous characters.
106 /^[a-zA-Z0-9+._, @-]+$/;
108 sub valid_web_url {
109 $_ = $_[0];
110 /^http:\/\/[a-zA-Z0-9-.]+(\/[_\%a-zA-Z0-9.\/~:-]*)?(#[a-zA-Z0-9._-]+)?$/;
112 sub valid_repo_url {
113 $_ = $_[0];
114 /^(http|git|svn|darcs|bzr):\/\/[a-zA-Z0-9-.]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/;