lib/POE/Component/IRC/Plugin/NoPaste.pm

   1 # -*- cperl -*-
   2 package POE::Component::IRC::Plugin::NoPaste;
   3 use strict;
   4 use warnings;
   5 use POE qw(
   6            Component::IRC::Plugin::NoPaste::Httpd
   7            Component::IRC::Plugin::NoPaste::DB
   8           );
   9 use POE::Component::IRC::Plugin qw(:ALL);
  10 use Encode qw(from_to);
  11 use Locale::TextDomain qw(pci-nopaste);
  12 use URI;
  13 use Net::Domain qw(hostfqdn);
  14 use Hash::Util qw(lock_keys);
  15 our $VERSION = '0.01';
  16
  17 #$SIG{__DIE__} = sub { print "$_[0]\n"; };
  18
  19 sub new {
  20     my ($class, $config) = @_;
  21     my $this = bless {} => $class;
  22
  23     $this->{config} = $config; # comes from yaml
  24
  25     $this->{httpd_alias} = undef;
  26     $this->{irc} = undef;
  27
  28     $this->{db} = POE::Component::IRC::Plugin::NoPaste::DB->new($config);
  29
  30     $this->{name_to_channel} = {}; # name => /channels/*
  31     # Note: keys of hash are name of channels which are encoded in
  32     #       channel's specific charset, and are lowercased.
  33     foreach my $ch (@{$config->{channels}}) {
  34         my $name = $ch->{name};
  35         from_to $name, 'UTF-8' => $ch->{charset};
  36         $this->{name_to_channel}{lc $name} = $ch;
  37     }
  38
  39     $this->{id_to_channel} = {}; # id => /channels/*
  40     foreach my $ch (@{$config->{channels}}) {
  41         $this->{id_to_channel}{$ch->{id}} = $ch;
  42     }
  43
  44     lock_keys %$this;
  45
  46     $this;
  47 }
  48
  49 sub PCI_register {
  50     my ($this, $irc) = @_;
  51
  52     $this->{irc} = $irc;
  53
  54     $this->{httpd_alias} =
  55       POE::Component::IRC::Plugin::NoPaste::Httpd->spawn($this);
  56
  57     $irc->plugin_register(
  58         $this,
  59         'SERVER',
  60         qw(001 public),
  61        );
  62
  63     $irc->yield(
  64         connect => $this->{config}{irc});
  65
  66     return 1;
  67 }
  68
  69 sub PCI_unregister {
  70     my ($this, $irc) = @_;
  71
  72     $poe_kernel->post(
  73         $this->{httpd_alias} => 'shutdown');
  74
  75     return 1;
  76 }
  77
  78 sub S_001 {
  79     my ($this, $irc, $line) = @_;
  80
  81     $this->log(__x(
  82         "connected to {server}:{port}.",
  83         server => $this->{config}{irc}{server},
  84         port   => $this->{config}{irc}{port}));
  85
  86     foreach my $ch (@{$this->{config}{channels}}) {
  87         my $name = $ch->{name};
  88         from_to $name, 'UTF-8' => $ch->{charset};
  89
  90         $irc->yield(
  91             join => $name);
  92     }
  93
  94     return PCI_EAT_NONE;
  95 }
  96
  97 sub S_public {
  98     my ($this, $irc, $from, $to, $msg) = @_;
  99
 100     local $SIG{__DIE__} = sub {
 101         print STDERR $_[0], "\n";
 102     };
 103
 104     my $mynick = $irc->nick_name;
 105     my $ch = $this->{name_to_channel}{lc $$to->[0]};
 106
 107     if ($$msg =~ m/$mynick/i and # Never use /o flag.
 108           defined $ch) {
 109
 110         local $ENV{LANGUAGE} = $ch->{locale};
 111
 112         my $name = $ch->{name};
 113         from_to $name, 'UTF-8' => $ch->{charset};
 114
 115         my $reply = __x(
 116             "{nick}: The NoPaste for {channel} is at {url}",
 117             nick    => (split /!/, $$from)[0],
 118             channel => $ch->{name},
 119             url     => do {
 120                 my $uri = URI->new;
 121                 $uri->scheme('http');
 122                 $uri->host(hostfqdn);
 123                 $uri->port($this->{config}{httpd}{port});
 124                 $uri->path("/nopaste/$ch->{id}/");
 125                 $uri->canonical->as_string;
 126             },
 127            );
 128         from_to $reply, 'UTF-8' => $ch->{charset};
 129
 130         $irc->yield(
 131             privmsg => $name => $reply);
 132     }
 133
 134     return PCI_EAT_NONE;
 135 }
 136
 137 sub log {
 138     my ($this, $msg) = @_;
 139
 140     print STDERR "NoPaste: $msg\n";
 141 }
 142
 143 sub pickup_writable {
 144     my ($this, $channel_id, $host) = @_;
 145
 146     $this->pickup(write => $channel_id, $host);
 147 }
 148
 149 sub pickup_readable {
 150     my ($this, $channel_id, $host) = @_;
 151
 152     $this->pickup(read => $channel_id, $host);
 153 }
 154
 155 sub pickup {
 156     # $what: 'read' or 'write'
 157     my ($this, $what, $channel_id, $host) = @_;
 158
 159     my $ch = $this->{id_to_channel}{$channel_id};
 160     $ch or return ();
 161
 162     my $name = $ch->{name};
 163     from_to $name, 'UTF-8' => $ch->{charset};
 164
 165     my $restrict = $ch->{restriction}{$what};
 166     grep {
 167         #$this->log("restrict: $restrict, name: $name, nick: $_");
 168         if (not $this->{irc}->nick_info($_)) {
 169             0;
 170         }
 171         elsif ($host ne $this->{irc}->nick_info($_)->{Host}) {
 172             0;
 173         }
 174         elsif ($restrict eq 'op') {
 175             $this->{irc}->is_channel_operator($name, $_);
 176         }
 177         elsif ($restrict eq 'halfop') {
 178             $this->{irc}->is_channel_halfop($name, $_);
 179         }
 180         elsif ($restrict eq 'voice') {
 181             $this->{irc}->has_channel_voice($name, $_);
 182         }
 183         elsif ($restrict eq 'member') {
 184             1;
 185         }
 186         else {
 187             0;
 188         }
 189     } $this->{irc}->channel_list($name);
 190 }
 191
 192 sub gen_unwritable_error {
 193     my ($this, $ch) = @_;
 194
 195     my $msg = __"Sorry, but you can't paste to this channel;\n";
 196
 197     $_ = $ch->{restriction}{write};
 198     if ($_ eq 'op') {
 199         $msg .= __(
 200             # "it" means "this channel"
 201             "allowed only for those who have op in it.");
 202     }
 203     elsif ($_ eq 'halfop') {
 204         $msg .= __"allowed only for those who have halfop in it.";
 205     }
 206     elsif ($_ eq 'voice') {
 207         $msg .= __"allowed only for those who have voice in it.";
 208     }
 209     elsif ($_ eq 'member') {
 210         $msg .= __"allowed only for those who are in it.";
 211     }
 212
 213     $msg;
 214 }
 215
 216 sub gen_unreadable_error {
 217     my ($this, $ch) = @_;
 218
 219     my $msg = __"Sorry, but you can't read posts pasted to this channel;\n";
 220
 221     $_ = $ch->{restriction}{read};
 222     if ($_ eq 'op') {
 223         $msg .= __(
 224             # "it" means "this channel"
 225             "allowed only for those who have op in it.");
 226     }
 227     elsif ($_ eq 'halfop') {
 228         $msg .= __"allowed only for those who have halfop in it.";
 229     }
 230     elsif ($_ eq 'voice') {
 231         $msg .= __"allowed only for those who have voice in it.";
 232     }
 233     elsif ($_ eq 'member') {
 234         $msg .= __"allowed only for those who are in it.";
 235     }
 236
 237     $msg;
 238 }
 239
 240 1;
 241 __END__
 242
 243 # Below is stub documentation for your module. You'd better edit it!
 244
 245 =head1 NAME
 246
 247 POE::Component::IRC::Plugin::NoPaste - Perl extension for blah blah blah
 248
 249 =head1 SYNOPSIS
 250
 251   use POE::Component::IRC::Plugin::NoPaste;
 252   blah blah blah
 253
 254 =head1 DESCRIPTION
 255
 256 Stub documentation for POE::Component::IRC::Plugin::NoPaste, created by h2xs. It looks like the
 257 author of the extension was negligent enough to leave the stub
 258 unedited.
 259
 260 Blah blah blah.
 261
 262 =head2 EXPORT
 263
 264 None by default.
 265
 266
 267
 268 =head1 SEE ALSO
 269
 270 Mention other useful documentation such as the documentation of
 271 related modules or operating system documentation (such as man pages
 272 in UNIX), or any relevant external documentation such as RFCs or
 273 standards.
 274
 275 If you have a mailing list set up for your module, mention it here.
 276
 277 If you have a web site set up for your module, mention it here.
 278
 279 =head1 AUTHOR
 280
 281 Administrador, E<lt>admin@apple.comE<gt>
 282
 283 =head1 COPYRIGHT AND LICENSE
 284
 285 Copyright (C) 2005 by Administrador
 286
 287 This library is free software; you can redistribute it and/or modify
 288 it under the same terms as Perl itself, either Perl version 5.8.6 or,
 289 at your option, any later version of Perl 5 you may have available.
 290
 291
 292 =cut