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
  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 ('', ('.', '/', 2..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) = @_;
  55
  56         rename "$path.lock", $path or die "$path unlock failed: $!";
  57 }
  58
  59 sub filedb_atomic_append {
  60         my ($file, $line) = @_;
  61         my $id = 65536;
  62
  63         open my $src, $file or die "$file open for reading failed: $!";
  64         my $dst = lock_file($file);
  65
  66         while (<$src>) {
  67                 my $aid = (split /:/)[2];
  68                 $id = $aid + 1 if ($aid >= $id);
  69
  70                 print $dst $_ or die "$file(l) write failed: $!";
  71         }
  72
  73         $line =~ s/\\i/$id/g;
  74         print $dst "$line\n" or die "$file(l) write failed: $!";
  75
  76         close $dst or die "$file(l) close failed: $!";
  77         close $src;
  78
  79         unlock_file($file);
  80
  81         $id;
  82 }
  83
  84 sub filedb_atomic_edit {
  85         my ($file, $fn) = @_;
  86
  87         open my $src, $file or die "$file open for reading failed: $!";
  88         my $dst = lock_file($file);
  89
  90         while (<$src>) {
  91                 print $dst $fn->($_) or die "$file(l) write failed: $!";
  92         }
  93
  94         close $dst or die "$file(l) close failed: $!";
  95         close $src;
  96
  97         unlock_file($file);
  98 }
  99
 100 sub valid_email {
 101         $_ = $_[0];
 102         /^[a-zA-Z0-9+._-]+@[a-zA-Z0-9-.]+$/;
 103 }
 104 sub valid_email_multi {
 105         $_ = $_[0];
 106         # More relaxed, we just want to avoid too dangerous characters.
 107         /^[a-zA-Z0-9+._, @-]+$/;
 108 }
 109 sub valid_web_url {
 110         $_ = $_[0];
 111         /^https?:\/\/[a-zA-Z0-9-.:]+(\/[_\%a-zA-Z0-9.\/~:?&=;-]*)?(#[a-zA-Z0-9._-]+)?$/;
 112 }
 113 sub valid_repo_url {
 114         $_ = $_[0];
 115         /^(https?|git|svn(\+http)?|svn(\+https)?|darcs|bzr):\/\/[a-zA-Z0-9-.:]+(\/[_\%a-zA-Z0-9.\/~-]*)?$/;
 116 }
 117
 118
 119 1;