Context.pm

   1 #**************************************************************************
   2 #   Copyright (C) 2009 by Michael Andreen <harvATruinDOTnu>               *
   3 #                                                                         *
   4 #   This program is free software; you can redistribute it and/or modify  *
   5 #   it under the terms of the GNU General Public License as published by  *
   6 #   the Free Software Foundation; either version 2 of the License, or     *
   7 #   (at your option) any later version.                                   *
   8 #                                                                         *
   9 #   This program is distributed in the hope that it will be useful,       *
  10 #   but WITHOUT ANY WARRANTY; without even the implied warranty of        *
  11 #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *
  12 #   GNU General Public License for more details.                          *
  13 #                                                                         *
  14 #   You should have received a copy of the GNU General Public License     *
  15 #   along with this program; if not, write to the                         *
  16 #   Free Software Foundation, Inc.,                                       *
  17 #   51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.         *
  18 #**************************************************************************/
  19
  20 package NDIRC::Context;
  21 use strict;
  22 use warnings;
  23 use feature ':5.10';
  24
  25 use Moose;
  26 use namespace::autoclean;
  27
  28 use Set::Object ();
  29
  30 has channel => (
  31         is => 'ro',
  32         isa => 'Str',
  33         required => 1
  34 );
  35
  36 has roles => (
  37         is => 'ro',
  38         isa => 'Object',
  39         lazy_build => 1
  40 );
  41
  42 has uid => (
  43         is => 'ro',
  44         isa => 'Int',
  45         lazy_build => 1
  46 );
  47
  48 has disp => (
  49         is => 'ro',
  50         isa => 'Object',
  51         required => 1
  52 );
  53
  54 has model => (
  55         is => 'ro',
  56         isa => 'Object',
  57         required => 1
  58 );
  59
  60 has bot => (
  61         is => 'ro',
  62         isa => 'Object',
  63         required => 1
  64 );
  65
  66 sub assert_user_roles {
  67         my ($self,@roles) = @_;
  68         return 1 unless @roles;
  69
  70         my $need = Set::Object->new(@roles);
  71
  72         if ($self->roles->superset($need)){
  73                 return 1;
  74         }
  75
  76         die "Access denied";
  77 }
  78
  79 sub check_user_roles {
  80         my ($self,@roles) = @_;
  81
  82         local $@;
  83         eval { $self->assert_user_roles(@roles) };
  84 }
  85
  86 sub reply {
  87 }
  88
  89 sub message {
  90 }
  91
  92 sub intel_log {
  93         my ($c,$planet, $message) = @_;
  94         my $log = $c->model->prepare_cached(q{
  95 INSERT INTO forum_posts (ftid,uid,message) VALUES(
  96         (SELECT ftid FROM planets WHERE pid = $3),$1,$2)
  97                 });
  98         $log->execute($c->uid,$message,$planet);
  99 }
 100
 101 sub def_log {
 102         my ($c,$call, $message) = @_;
 103         my $log = $c->model->prepare(q{
 104 INSERT INTO forum_posts (ftid,uid,message) VALUES(
 105         (SELECT ftid FROM calls WHERE call = $3),$1,$2)
 106                 });
 107         $log->execute($c->uid,$message,$call);
 108 }
 109
 110 sub _build_roles {
 111         my ($self) = @_;
 112
 113         my $query = $self->model->prepare(q{
 114 SELECT role FROM group_roles
 115 WHERE gid IN (SELECT gid FROM groupmembers JOIN users USING (uid)
 116         WHERE uid = $1)
 117                 });
 118         $query->execute($self->uid);
 119
 120         my @roles;
 121         while (my $group = $query->fetchrow_hashref){
 122                 push @roles,$group->{role};
 123         }
 124         return Set::Object->new(@roles);
 125 }
 126
 127 sub _build_uid {
 128         my ($self) = @_;
 129
 130         return -4;
 131 }
 132
 133 sub valuecolor {
 134         shift @_;
 135         my $s = $_;
 136         return $s;
 137 }
 138
 139 __PACKAGE__->meta->make_immutable;
 140 1;