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
  27 use Set::Object ();
  28
  29 has host => (
  30         is => 'ro',
  31         isa => 'Str',
  32         required => 1
  33 );
  34
  35 has nick => (
  36         is => 'ro',
  37         isa => 'Str',
  38         required => 1
  39 );
  40
  41 has channel => (
  42         is => 'ro',
  43         isa => 'Str',
  44         required => 1
  45 );
  46
  47 has roles => (
  48         is => 'ro',
  49         isa => 'Object',
  50         lazy_build => 1
  51 );
  52
  53 has uid => (
  54         is => 'ro',
  55         isa => 'Int',
  56         lazy_build => 1
  57 );
  58
  59 has disp => (
  60         is => 'ro',
  61         isa => 'Object',
  62         required => 1
  63 );
  64
  65 has model => (
  66         is => 'ro',
  67         isa => 'Object',
  68         required => 1
  69 );
  70
  71 has server => (
  72         is => 'ro',
  73         isa => 'Object',
  74         required => 1
  75 );
  76
  77 has reply_string => (
  78         is => 'ro',
  79         isa => 'Str',
  80         required => 1,
  81 );
  82
  83 sub assert_user_roles {
  84         my ($self,@roles) = @_;
  85         return 1 unless @roles;
  86
  87         my $need = Set::Object->new(@roles);
  88
  89         if ($self->roles->superset($need)){
  90                 return 1;
  91         }
  92
  93         die "Access denied";
  94 }
  95
  96 sub check_user_roles {
  97         my ($self,@roles) = @_;
  98
  99         local $@;
 100         eval { $self->assert_user_roles(@roles) };
 101 }
 102
 103 sub reply {
 104         my ($self,$msg) = @_;
 105
 106         my @command = split / /, $self->reply_string;
 107         $self->message(@command, $msg);
 108 }
 109
 110 sub message {
 111         my ($self,$command, $target, $msg) = @_;
 112
 113         $msg =~ s`<b>(.*?)</b>`${\(chr(2))}$1${\(chr(15))}`gi;
 114         $msg =~ s`<c(\d+)>(.*?)</c>`${\(chr(3))}$1$2${\(chr(15))}`gi;
 115
 116         #Split the message, using the, slightly modified, algorithm from splitlong.pl in the irssi distribution.
 117         if ($command eq 'privmsg'){
 118                 my $lend = ' ...';
 119                 my $lstart = '... ';
 120                 my $maxlength = $self->server->{msg_length} - bytes::length("privmsg $target :" . $self->server->nick_name());
 121                 my $maxlength2 = $maxlength - bytes::length($lend);
 122
 123                 if (bytes::length($msg) > ($maxlength)) {
 124                         my @spltarr;
 125
 126                         while (bytes::length($msg) > ($maxlength)) {
 127                                 my $pos = rindex($msg, " ", $maxlength2);
 128                                 push @spltarr, substr($msg, 0, ($pos < ($maxlength/10 + 4)) ? $maxlength2  : $pos)  . $lend;
 129                                 $msg = $lstart . substr($msg, ($pos < ($maxlength/10 + 4)) ? $maxlength2 : $pos+1);
 130                         }
 131
 132                         push @spltarr, $msg;
 133                         for (@spltarr) {
 134                                 $self->command($command, $target, $_);
 135                         }
 136                         return;
 137                 }
 138         }
 139         $self->command($command, $target, $msg);
 140 }
 141
 142 sub command {
 143         my ($self,@command) = @_;
 144
 145         $self->server->yield(@command);
 146 }
 147
 148 sub intel_log {
 149         my ($c,$planet, $message) = @_;
 150         my $log = $c->model->prepare_cached(q{
 151 INSERT INTO forum_posts (ftid,uid,message) VALUES(
 152         (SELECT ftid FROM planets WHERE pid = $3),$1,$2)
 153                 });
 154         $log->execute($c->uid,$message,$planet);
 155 }
 156
 157 sub def_log {
 158         my ($c,$call, $message) = @_;
 159         my $log = $c->model->prepare(q{
 160 INSERT INTO forum_posts (ftid,uid,message) VALUES(
 161         (SELECT ftid FROM calls WHERE call = $3),$1,$2)
 162                 });
 163         $log->execute($c->uid,$message,$call);
 164 }
 165
 166 sub _build_roles {
 167         my ($self) = @_;
 168
 169         my $query = $self->model->prepare(q{
 170 SELECT role FROM group_roles
 171 WHERE gid IN (SELECT gid FROM groupmembers JOIN users USING (uid)
 172         WHERE hostmask = $1)
 173                 });
 174         $query->execute($self->host);
 175
 176         my @roles;
 177         while (my $group = $query->fetchrow_hashref){
 178                 push @roles,$group->{role};
 179         }
 180         return Set::Object->new(@roles);
 181 }
 182
 183 sub _build_uid {
 184         my ($self) = @_;
 185
 186         my $query = $self->model->prepare(q{
 187 SELECT uid FROM users
 188 WHERE hostmask = $1
 189                 });
 190         $query->execute($self->host);
 191
 192         if (my ($uid) = $query->fetchrow_array){
 193                 $query->finish;
 194                 return $uid;
 195         }
 196         return -4;
 197 }
 198
 199 1;