# -*- cperl -*- package POE::Component::IRC::Plugin::NoPaste; use strict; use warnings; use POE qw( Component::IRC::Plugin::NoPaste::Httpd Component::IRC::Plugin::NoPaste::DB ); use POE::Component::IRC::Plugin qw(:ALL); use Encode qw(from_to); use Locale::TextDomain qw(pci-nopaste); use URI; use Net::Domain qw(hostfqdn); use Hash::Util qw(lock_keys); our $VERSION = '0.01'; #$SIG{__DIE__} = sub { print "$_[0]\n"; }; sub new { my ($class, $config) = @_; my $this = bless {} => $class; $this->{config} = $config; # comes from yaml $this->{httpd_alias} = undef; $this->{irc} = undef; $this->{db} = POE::Component::IRC::Plugin::NoPaste::DB->new($config); $this->{name_to_channel} = {}; # name => /channels/* # Note: keys of hash are name of channels which are encoded in # channel's specific charset, and are lowercased. foreach my $ch (@{$config->{channels}}) { my $name = $ch->{name}; from_to $name, 'UTF-8' => $ch->{charset}; $this->{name_to_channel}{lc $name} = $ch; } $this->{id_to_channel} = {}; # id => /channels/* foreach my $ch (@{$config->{channels}}) { $this->{id_to_channel}{$ch->{id}} = $ch; } lock_keys %$this; $this; } sub PCI_register { my ($this, $irc) = @_; $this->{irc} = $irc; $this->{httpd_alias} = POE::Component::IRC::Plugin::NoPaste::Httpd->spawn($this); $irc->plugin_register( $this, 'SERVER', qw(001 public), ); $irc->yield( connect => $this->{config}{irc}); return 1; } sub PCI_unregister { my ($this, $irc) = @_; $poe_kernel->post( $this->{httpd_alias} => 'shutdown'); return 1; } sub S_001 { my ($this, $irc, $line) = @_; $this->log(__x( "connected to {server}:{port}.", server => $this->{config}{irc}{server}, port => $this->{config}{irc}{port})); foreach my $ch (@{$this->{config}{channels}}) { my $name = $ch->{name}; from_to $name, 'UTF-8' => $ch->{charset}; $irc->yield( join => $name); } return PCI_EAT_NONE; } sub S_public { my ($this, $irc, $from, $to, $msg) = @_; local $SIG{__DIE__} = sub { print STDERR $_[0], "\n"; }; my $mynick = $irc->nick_name; my $ch = $this->{name_to_channel}{lc $$to->[0]}; if ($$msg =~ m/$mynick/i and # Never use /o flag. defined $ch) { local $ENV{LANGUAGE} = $ch->{locale}; my $name = $ch->{name}; from_to $name, 'UTF-8' => $ch->{charset}; my $reply = __x( "{nick}: The NoPaste for {channel} is at {url}", nick => (split /!/, $$from)[0], channel => $ch->{name}, url => do { my $uri = URI->new; $uri->scheme('http'); $uri->host(hostfqdn); $uri->port($this->{config}{httpd}{port}); $uri->path("/nopaste/$ch->{id}/"); $uri->canonical->as_string; }, ); from_to $reply, 'UTF-8' => $ch->{charset}; $irc->yield( privmsg => $name => $reply); } return PCI_EAT_NONE; } sub log { my ($this, $msg) = @_; print STDERR "NoPaste: $msg\n"; } sub pickup_writable { my ($this, $channel_id, $host) = @_; $this->pickup(write => $channel_id, $host); } sub pickup_readable { my ($this, $channel_id, $host) = @_; $this->pickup(read => $channel_id, $host); } sub pickup { # $what: 'read' or 'write' my ($this, $what, $channel_id, $host) = @_; my $ch = $this->{id_to_channel}{$channel_id}; $ch or return (); my $name = $ch->{name}; from_to $name, 'UTF-8' => $ch->{charset}; my $restrict = $ch->{restriction}{$what}; grep { #$this->log("restrict: $restrict, name: $name, nick: $_"); if (not $this->{irc}->nick_info($_)) { 0; } elsif ($host ne $this->{irc}->nick_info($_)->{Host}) { 0; } elsif ($restrict eq 'op') { $this->{irc}->is_channel_operator($name, $_); } elsif ($restrict eq 'halfop') { $this->{irc}->is_channel_halfop($name, $_); } elsif ($restrict eq 'voice') { $this->{irc}->has_channel_voice($name, $_); } elsif ($restrict eq 'member') { 1; } else { 0; } } $this->{irc}->channel_list($name); } sub gen_unwritable_error { my ($this, $ch) = @_; my $msg = __"Sorry, but you can't paste to this channel;\n"; $_ = $ch->{restriction}{write}; if ($_ eq 'op') { $msg .= __( # "it" means "this channel" "allowed only for those who have op in it."); } elsif ($_ eq 'halfop') { $msg .= __"allowed only for those who have halfop in it."; } elsif ($_ eq 'voice') { $msg .= __"allowed only for those who have voice in it."; } elsif ($_ eq 'member') { $msg .= __"allowed only for those who are in it."; } $msg; } sub gen_unreadable_error { my ($this, $ch) = @_; my $msg = __"Sorry, but you can't read posts pasted to this channel;\n"; $_ = $ch->{restriction}{read}; if ($_ eq 'op') { $msg .= __( # "it" means "this channel" "allowed only for those who have op in it."); } elsif ($_ eq 'halfop') { $msg .= __"allowed only for those who have halfop in it."; } elsif ($_ eq 'voice') { $msg .= __"allowed only for those who have voice in it."; } elsif ($_ eq 'member') { $msg .= __"allowed only for those who are in it."; } $msg; } 1; __END__ # Below is stub documentation for your module. You'd better edit it! =head1 NAME POE::Component::IRC::Plugin::NoPaste - Perl extension for blah blah blah =head1 SYNOPSIS use POE::Component::IRC::Plugin::NoPaste; blah blah blah =head1 DESCRIPTION Stub documentation for POE::Component::IRC::Plugin::NoPaste, created by h2xs. It looks like the author of the extension was negligent enough to leave the stub unedited. Blah blah blah. =head2 EXPORT None by default. =head1 SEE ALSO Mention other useful documentation such as the documentation of related modules or operating system documentation (such as man pages in UNIX), or any relevant external documentation such as RFCs or standards. If you have a mailing list set up for your module, mention it here. If you have a web site set up for your module, mention it here. =head1 AUTHOR Administrador, Eadmin@apple.comE =head1 COPYRIGHT AND LICENSE Copyright (C) 2005 by Administrador This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.6 or, at your option, any later version of Perl 5 you may have available. =cut