Girocco/Util.pm

   1 package Girocco::Util;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Girocco::Config;
   7
   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 filedb_atomic_grep
  13                          valid_email valid_email_multi
  14                          valid_repo_url valid_web_url);
  15 }
  16
  17
  18 sub scrypt {
  19         my ($pwd) = @_;
  20         crypt($pwd||'', join ('', ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]));
  21 }
  22
  23 sub jailed_file {
  24         my ($filename) = @_;
  25         $filename =~ s,^/,,;
  26         $Girocco::Config::chroot."/$filename";
  27 }
  28
  29 sub lock_file {
  30         my ($path) = @_;
  31
  32         $path .= '.lock';
  33
  34         use Errno qw(EEXIST);
  35         use Fcntl qw(O_WRONLY O_CREAT O_EXCL);
  36         use IO::Handle;
  37         my $handle = new IO::Handle;
  38
  39         unless (sysopen($handle, $path, O_WRONLY|O_CREAT|O_EXCL)) {
  40                 my $cnt = 0;
  41                 while (not sysopen($handle, $path, O_WRONLY|O_CREAT|O_EXCL)) {
  42                         ($! == EEXIST) or die "$path open failed: $!";
  43                         ($cnt++ < 16) or die "$path open failed: cannot open lockfile";
  44                         sleep(1);
  45                 }
  46         }
  47         # XXX: filedb-specific
  48         chmod 0664, $path or die "$path g+w failed: $!";
  49
  50         $handle;
  51 }
  52
  53 sub unlock_file {
  54         my ($path, $noreplace) = @_;
  55
  56         if (!$noreplace) {
  57                 rename "$path.lock", $path or die "$path unlock failed: $!";
  58         } else {
  59                 unlink "$path.lock" or die "$path unlock failed: $!";
  60         }
  61 }
  62
  63 sub filedb_atomic_append {
  64         my ($file, $line) = @_;
  65         my $id = 65536;
  66
  67         open my $src, $file or die "$file open for reading failed: $!";
  68         my $dst = lock_file($file);
  69
  70         while (<$src>) {
  71                 my $aid = (split /:/)[2];
  72                 $id = $aid + 1 if ($aid >= $id);
  73
  74                 print $dst $_ or die "$file(l) write failed: $!";
  75         }
  76
  77         $line =~ s/\\i/$id/g;
  78         print $dst "$line\n" or die "$file(l) write failed: $!";
  79
  80         close $dst or die "$file(l) close failed: $!";
  81         close $src;
  82
  83         unlock_file($file);
  84
  85         $id;
  86 }
  87
  88 sub filedb_atomic_edit {
  89         my ($file, $fn) = @_;
  90
  91         open my $src, $file or die "$file open for reading failed: $!";
  92         my $dst = lock_file($file);
  93
  94         while (<$src>) {
  95                 print $dst $fn->($_) or die "$file(l) write failed: $!";
  96         }
  97
  98         close $dst or die "$file(l) close failed: $!";
  99         close $src;
 100
 101         unlock_file($file);
 102 }
 103
 104 sub filedb_atomic_grep {
 105         my ($file, $fn) = @_;
 106         my @results = ();
 107
 108         open my $src, $file or die "$file open for reading failed: $!";
 109         my $dst = lock_file($file);
 110
 111         while (<$src>) {
 112                 my $result = $fn->($_);
 113                 push(@results, $result) if $result;
 114         }
 115
 116         close $dst or die "$file(l) close failed: $!";
 117         close $src;
 118
 119         unlock_file($file, 1);
 120         return @results;
 121 }
 122
 123 sub valid_email {
 124         $_ = $_[0];
 125         /^[a-zA-Z0-9+._-]+@[a-zA-Z0-9.-]+$/;
 126 }
 127 sub valid_email_multi {
 128         $_ = $_[0];
 129         # More relaxed, we just want to avoid too dangerous characters.
 130         /^[a-zA-Z0-9+._, @-]+$/;
 131 }
 132 sub valid_web_url {
 133         $_ = $_[0];
 134         /^https?:\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~:?&=;-]*)?(#[a-zA-Z0-9._-]+)?$/;
 135 }
 136 sub valid_repo_url {
 137         $_ = $_[0];
 138         /^(https?|git|svn(\+http)?|svn(\+https)?|darcs|bzr):\/\/[a-zA-Z0-9.:-]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/;
 139 }
 140
 141
 142 1;