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