--- /dev/null
+Revision history for Perl extension POE::Component::IRC::Plugin::NoPaste.
+
+0.01 Wed Sep 14 01:22:49 2005
+ - original version; created by h2xs 1.23 with options
+ -X POE::Component::IRC::Plugin::NoPaste
+
--- /dev/null
+#use 5.008006;
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ NAME => 'POE::Component::IRC::Plugin::NoPaste',
+ VERSION_FROM => 'lib/POE/Component/IRC/Plugin/NoPaste.pm', # finds $VERSION
+ PREREQ_PM => {
+ Carp => 0,
+ CGI => 2.69,
+ DBD::SQLite => 1.08,
+ DBI => 0,
+ Encode => 0,
+ Error => 0,
+ Exporter => 0,
+ File::Copy => 0,
+ File::Spec => 0,
+ File::stat => 0,
+ Getopt::Long => 0,
+ Hash::Util => 0,
+ HTTP::Status => 0,
+ Locale::TextDomain => 0,
+ Net::Domain => 0,
+ POE::Component::IRC => 4.69,
+ POE::Component::Server::HTTP => 0.08,
+ Pod::Usage => 0,
+ Time::Format => 0,
+ UNIVERSAL => 0,
+ URI => 0,
+ URI::QueryParam => 0,
+ YAML => 0,
+ },
+ EXE_FILES => [qw(bin/pci-nopaste)],
+ ($] >= 5.005 ? ## Add these new keywords supported since 5.005
+ (ABSTRACT_FROM => 'lib/POE/Component/IRC/Plugin/NoPaste.pm', # retrieve abstract from module
+ AUTHOR => 'phonohawk <phonohawk@ps.sakura.ne.jp>') : ()),
+);
--- /dev/null
+POE-Component-IRC-Plugin-NoPaste version 0.01
+=============================================
+
+The README is used to introduce the module and provide instructions on
+how to install the module, any machine dependencies it may have (for
+example C compilers and installed libraries) and any other information
+that should be provided before the module is installed.
+
+A README file is required for CPAN modules since CPAN extracts the
+README file from a module distribution so that people browsing the
+archive can use it get an idea of the modules uses. It is usually a
+good idea to provide version information here so that people can
+decide whether fixes for the module are worth downloading.
+
+INSTALLATION
+
+To install this module type the following:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+DEPENDENCIES
+
+This module requires these other modules and libraries:
+
+ blah blah blah
+
+COPYRIGHT AND LICENCE
+
+Put the correct copyright and licence information here.
+
+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.
+
+
--- /dev/null
+Notes on National Language Support (NLS)
+****************************************
+
+This package is internationalized with libintl-perl, a free
+internationalization library for Perl, you will need to install a copy of
+libintl-perl in order to use the package. You can get libintl-perl from the
+Comprehensive Perl Archive Network CPAN at http://www.cpan.org/.
+
+The following notes are meant to be a quick start guide for somewhat
+experienced users and system administrators and many important details had to
+be omitted for brevity. If you have any difficulties with the
+internationalization features of this package, no matter if you are a
+programmer, a translator, or an end user, feel free to ask at the mailing list
+for libintl-perl. To do so, send an e-mail to the address
+<libintl-perl AT imperia DOT net> (please replace "AT" with a "@", and "DOT"
+with a dot ".").
+
+You can subscribe to this list at
+
+ http://ml.imperia.org/mailman/listinfo/libintl-perl
+
+A searchable archive of earlier postings is located at
+
+ http://ml.imperia.org/libintl-perl/
+
+You may already find an answer to your question there.
+
+Feel free to include this document in your own Perl packages internationalized
+with libintl-perl, no severe copyright restrictions apply. You should send
+corrections or improvements to the author Guido Flohr <guido AT imperia DOT
+net>, so that others can benefit from your changes.
+
+The End User's View
+===================
+
+The installation routine for this package will automatically take care that
+your system has a sufficient version of libintl-perl installed. This is
+basically sufficient for proper operation, but - especially if
+internationalized software is new to you - you should read on carefully in
+order to fully benefit from the internationalization (I18N) features of this
+package.
+
+Perl Setup
+----------
+
+The I18N library libintl-perl will run with a wide range of Perl versions (at
+least from Perl version 5.005_03 to Perl 5.8.0) but you will experience slight
+difference in features and performance depending on the version of Perl you
+use.
+
+With Perl versions prior to 5.7.3 you can use the package for all European
+scripts (including those with Greek or Cyrillic scripts), and also for many
+scripts used outside Europe, like Arabic, Hebrew, Georgian, Vietnamese or
+Thai, more general all scripts using 8 bit charsets. Other scripts are only
+available if the translations in this package are provided in Unicode and they
+can only be output in Unicode.
+
+Beginning with Perl 5.7.3 the module Encode became part of the Perl core, and
+it offers you a much wider range of possible scripts. If you plan to use some
+of the lesser used scripts for Chinese, Japanese, and Korean, you should also
+install the module Encode::HanExtra.
+
+Setting Your Language
+---------------------
+
+Most modern systems are already prepared and configured for
+internationalization, and the user interface of the software you have
+installed will already be configured for your preferred language. Packages
+internationalized with libintl-perl will honor these configuration settings
+and will also operate in your preferred language if the necessary translations
+are available.
+
+The environment variable "LANGUAGE" has the highest precedence for
+translations. The most common format for this environment variable is a
+(lowercase) two-letter language code and an (uppercase) two-letter country
+code separated by an underscore "_", for example:
+
+ LANGUAGE=fr_BE
+ export LANGUAGE
+
+This will set your language preferences to French ("fr") for Belgium ("BE").
+Other examples are French for France ("fr_FR"), German for Austria ("de_AT"),
+and so on. You can also omit the country part ("FR", "DE", "IT", "RU", ...)
+in which case a default setting for the country will be assumed.
+
+If there are no translations available for your selected languages, the
+original message (normally in English) will be displayed.
+
+You can also define a chain of languages to be tried separated by a colon:
+
+ LANGUAGE=fr_BE:fr_FR:fr:it
+
+Read this as: "I want translations in French for Belgium. If they are not
+available try French for France, then any French translation, and finally
+Italian". Please note that this chain notation is only allowed for the
+environment variable "LANGUAGE", it is not valid for any of the following
+variables.
+
+If "LANGUAGE" is not set, the library checks the variable "LANG". It has the
+same syntax as "LANGUAGE" but does not allow the preferences chain with the
+colon syntax. After "LANG" the variable "LC_MESSAGES" (think "locale category
+messages") is tried, and finally "LC_ALL".
+
+Note for Microsoft Windows users: The locale preferences you have configured
+for your system cannot yet be evaluated by libintl-perl. This may change for
+future versions of libintl-perl but for the moment you have to make do with
+the instructions given above. In order to set environment variables, you have
+to right-click on the icon "My Computer" on your desktop, select "Properties"
+in the context menu, and then click the tab labelled "Environment variables".
+
+Setting the Output Charset
+--------------------------
+
+Even if you have managed to properly select your preferred language, you may
+still have difficulties reading the program languages, because libintl-perl
+was unable to determine the correct charset to use for messages. For example,
+it may assume Unicode ("UTF-8") but you really need ISO-Latin-1 (also known as
+"Latin-1" or "ISO-8859-1"). If this is the case, please set the environment
+variable "OUTPUT_CHARSET" to the appropriate value, for example:
+
+ OUTPUT_CHARSET=iso-8859-1
+ export OUTPUT_CHARSET
+
+Charset names are case-insensitive, i. e. "LATIN-1" is the equivalent to
+"Latin-1" or even "lAtIn-1".
+
+Note: The output charset "utf8" is NOT recognized. Please use the correct
+abbreviation "utf-8" (with a hyphen) instead.
+
+The Translator's View
+=====================
+
+If you want to contribute a new translation to this package, please contact
+the author first. Somebody may have already started this translation, and
+furthermore the package author will be able to give you detailled instructions
+and help.
+
+Translating a Perl package is not much work and it does not require any
+technical skills. If you are able to use the software itself, you will also
+be able to contribute a translation for your language. But why should you do
+that? You are able to read and understand this text and you will also be able
+to understand the English messages that the software spits out by default.
+
+Computers are an integral part of today's society. Computers are used to
+explore new sources of information, forbidding computers would be a modern
+form of censorship. Computers may also improve social life, the internet
+helps people to find contacts in their area and all over the world, even if
+they would otherwise be deprived from that because of a handicap, lack of money
+for traveling, or other reasons. In many societies, the ability to use and
+handle a computer also has a strong impact on your perspectives in life, you
+may not be able to find an adequate job because of your lack of computer
+experience, or you may even lose your job because of that.
+
+Everybody should benefit from computers, regardless of cultural
+background. Computers are expansive goods, and their price is already a high
+barrier to cross. If computers speak in a foreign language, the learning
+curve gets steeper and the barrier gets even higher. You can help the people
+that share your native language by contributing a translation. The author of
+this package has already prepared everything, the rest is up to you!
+
+The Programmer's View
+=====================
+
+You have downloaded this package because you want to use it in your own
+project(s). The fact that the package is internationalized with libintl-perl
+does not affect its usability in any way. But you should keep in mind that
+textual messages produced by the package may change according to the locale
+settings at run-time. This can lead to errors. For example, if you parse
+error messages produced by the package, you will most probably fail to detect
+what you are looking for, if these error messages are suddenly presented in
+another language or another output charset.
+
+It is probably needless to say that this is bad practice and an indicator for
+a poorly written interface. Either you have missed the correct method for
+determining the substance of the message in a locale-independent manner, or
+the author of the package has mis-designed the package interface. In any
+case, this is a technical problem that should be solved by technicians. You
+should not put that burden on the shoulders of your users but rather solve the
+problem in cooperation with the author of the module that causes it.
+
+If this is absolutely impossible, as a temporary workaround you can completely
+switch off the native language support of the package by setting the
+environment variable "LANGUAGE" to the special value "C":
+
+ BEGIN {
+ $ENV{LANGUAGE} = $ENV{LANG} = "C";
+ }
+
+The value "C" instructs libintl-perl to leave all messages untouched, and you
+can use the package as if it was not internationalized at all.
+
+If the project you are working on is not yet internationalized, you should
+consider to prepare it for internationalization now. Doing so is only little
+work for yourself, but results in a large benefit for the users of your
+software. The package "libintl-perl" ships with exhaustive documentation for
+programmers and a sample package that you can use as a skeleton for your own
+project(s). Internationalizing Perl software with libintl-perl is easy, the
+package that this file is a part of, prooves that.
+
+Guido Flohr
--- /dev/null
+#!/usr/bin/perl
+# -*- cperl -*-
+use strict;
+use warnings;
+
+BEGIN {
+ local $| = 1;
+ print ".:NoPaste:. loading bunch of modules... ";
+}
+
+use Locale::TextDomain qw(pci-nopaste);
+use YAML ();
+use Getopt::Long;
+use Pod::Usage;
+use POE qw(
+ Component::IRC::State
+ Component::IRC::Plugin::Connector
+ Component::IRC::Plugin::NoPaste
+ );
+use constant ALIAS => 'pci-nopaste';
+
+BEGIN {
+ print "done.\n";
+}
+
+my %opts;
+GetOptions(
+ 'help|h' => \$opts{help},
+ man => \$opts{man},
+ 'config|c=s' => \$opts{config},
+ );
+
+$opts{man} and
+ pod2usage(-verbose => 2);
+
+$opts{help} and
+ pod2usage(-verbose => 1);
+
+if (not $opts{config}) {
+ if (-f '/etc/pci-nopaste.yml') {
+ $opts{config} = '/etc/pci-nopaste.yml';
+ }
+ else {
+ die __x(
+ "{process}: option --config=<config-file> is missing.\n",
+ process => $0,
+ );
+ }
+}
+
+my $config = YAML::LoadFile($opts{config});
+my $irc = POE::Component::IRC::State->spawn;
+
+POE::Session->create(
+ package_states => [
+ __PACKAGE__, [ qw(_start _signal_stop) ],
+ ],
+ );
+
+$poe_kernel->run;
+exit 0;
+
+sub _start {
+ $_[KERNEL]->alias_set(ALIAS);
+ #foreach (qw[HUP INT QUIT ABRT TERM]) {
+# $_[KERNEL]->sig($_ => '_signal_stop');
+# }
+
+ $irc->plugin_add(
+ Connector => POE::Component::IRC::Plugin::Connector->new());
+
+ $irc->plugin_add(
+ NoPaste => POE::Component::IRC::Plugin::NoPaste->new($config));
+}
+
+sub _signal_stop {
+ $_[KERNEL]->sig_handled;
+
+ print STDERR __"Shutdown time has arrived. Telling components to stop...\n";
+
+ $_[KERNEL]->alias_remove(ALIAS);
+ $irc->yield('shutdown');
+}
--- /dev/null
+# -*- 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, E<lt>admin@apple.comE<gt>
+
+=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
--- /dev/null
+# -*- cperl -*-
+package POE::Component::IRC::Plugin::NoPaste::DB;
+use strict;
+use warnings;
+use DBI;
+use Hash::Util qw(lock_keys);
+
+sub new {
+ my ($class, $config) = @_;
+ my $this = bless {} => $class;
+
+ $this->{config} = $config;
+ $this->{dbh} = DBI->connect(
+ "dbi:SQLite:dbname=$config->{db}{file}", "", "", {
+ RaiseError => 1,
+ AutoCommit => 1,
+ });
+
+ lock_keys %$this;
+
+ $this->setup_db;
+ $this;
+}
+
+sub dbh {
+ my $this = shift;
+
+ $this->{dbh};
+}
+
+sub setup_db {
+ my $this = shift;
+
+ eval {
+ $this->{dbh}->do(q{
+ SELECT *
+ FROM post
+ LIMIT 0
+ });
+ };
+ if ($@) {
+ $this->{dbh}->do(q{
+CREATE TABLE post (
+ post_id INTEGER PRIMARY KEY, -- unique id of the post
+ channel_id VARCHAR(512) NOT NULL, -- id of the channel in ascii
+
+ posted_time INTEGER NOT NULL, -- timestamp in epoch
+ nick VARCHAR(512) NOT NULL, -- nick of the person who posted this
+ title BLOB NOT NULL, -- title of the post
+ body BLOB NOT NULL -- body of the post
+);
+});
+ }
+}
+
+1;
--- /dev/null
+# -*- cperl -*-
+package POE::Component::IRC::Plugin::NoPaste::Httpd;
+use strict;
+use warnings;
+require Exporter;
+BEGIN {
+ # with out this BEGIN block, NoPaste::Httpd::* can't import them by Exporter.
+ our @ISA = qw(Exporter);
+ our @EXPORT = qw(
+ notfound_handler
+ need_auth_handler
+ redirect_handler
+ internal_server_error_handler);
+}
+use POE qw(
+ Component::Server::HTTP
+ Component::IRC::Plugin::NoPaste::Template
+ Component::IRC::Plugin::NoPaste::StaticFile
+ Component::IRC::Plugin::NoPaste::Httpd::Index
+ Component::IRC::Plugin::NoPaste::Httpd::Pasted
+ );
+use CGI::Pretty qw(:standard);
+use HTTP::Status;
+use Carp;
+use Hash::Util qw(lock_keys);
+
+sub spawn {
+ my ($class, $nopaste) = @_;
+ my $this = bless {} => $class;
+
+ $this->{nopaste} = $nopaste;
+
+ $this->{my_alias} = undef;
+ $this->{httpd_alias} = undef;
+
+ lock_keys %$this;
+
+ POE::Session->create(
+ heap => $this,
+ package_states => [
+ __PACKAGE__, [ qw(_start shutdown) ],
+ ],
+ );
+
+ $this->{my_alias};
+}
+
+sub _start {
+ my $this = $_[HEAP];
+
+ $this->{my_alias} = 'PCI::Plugin::NoPaste::Httpd::' . $_[SESSION]->ID;
+ $_[KERNEL]->alias_set($this->{my_alias});
+
+ my $barrier = sub {
+ my $code = $_[0];
+ return sub {
+ my ($req, $resp) = @_;
+
+ local $ENV{OUTPUT_CHARSET} = 'UTF-8';
+
+ # copy the content of POST to query if needed.
+ if ($req->method eq 'POST' and
+ $req->headers->content_type eq 'application/x-www-form-urlencoded' and
+ !defined $req->uri->query) {
+ $_ = $req->content;
+ tr/\x0d\x0a//d;
+ $req->uri->query($_);
+ }
+
+ my $last_exception;
+ my $retval = eval {
+ local $SIG{__DIE__} = sub {
+ print $_[0];
+ $last_exception = Carp::longmess(@_);
+ };
+
+ $code->($this, @_);
+ }; if ($@) {
+ $retval = $this->internal_server_error_handler(
+ $req, $resp, $last_exception);
+ }
+
+ # complete the response
+ $resp->code or
+ $resp->code($retval);
+ $resp->message or
+ $resp->message(status_message($resp->code));
+
+ if (!length $resp->content) {
+ if ($resp->code >= 200 && $resp->code < 300) {
+ $retval = $this->internal_server_error_handler(
+ $req, $resp, 'Content handler did not set any content.');
+ }
+ elsif ($resp->code >= 300 && $resp->code < 400) {
+ # FIXME: complete a HTML which links to the destination of redirection
+ }
+ }
+
+ # default value of Content-Type is text/html
+ $resp->header('Content-Type') or
+ $resp->header('Content-Type' => 'text/html; charset=UTF-8');
+
+ # complete Content-Length
+ $resp->header('Content-Length') or
+ $resp->header('Content-Length' => length($resp->content));
+
+ # remove content if the method is HEAD
+ if ($req->method eq 'HEAD') {
+ $resp->content(undef);
+ }
+
+ return $retval;
+ };
+ };
+
+ $this->{httpd_alias} = POE::Component::Server::HTTP->new(
+ Port => $this->{nopaste}{config}{httpd}{port},
+ ContentHandler => {
+ '/'
+ => $barrier->(\¬found_handler),
+ '/css/'
+ => $barrier->(\&css_handler),
+ '/nopaste/'
+ => $barrier->(\&POE::Component::IRC::Plugin::NoPaste::Httpd::Index::handler),
+ '/post/'
+ => $barrier->(\&POE::Component::IRC::Plugin::NoPaste::Httpd::Index::handler),
+ '/pasted/'
+ => $barrier->(\&POE::Component::IRC::Plugin::NoPaste::Httpd::Pasted::handler),
+ },
+ Headers => {
+ Server => 'PCI::Plugin::NoPaste UI (Powered by PoCo::Server::HTTP)',
+ Connection => 'close',
+ },
+ )->{httpd};
+}
+
+sub shutdown {
+ my $this = $_[HEAP];
+
+ $_[KERNEL]->alias_remove($this->{my_alias});
+ $_[KERNEL]->call($this->{httpd_alias} => 'shutdown');
+}
+
+sub notfound_handler {
+ my ($this, $req, $resp) = @_;
+ my $t = POE::Component::IRC::Plugin::NoPaste::Template->new(
+ -data => static_file('tmpl/error.html'));
+ $t->expand(
+ status_code => '404',
+ status_message => 'Not Found',
+ requested_url => ''.$req->uri,
+ );
+ $resp->content($t->str);
+ return RC_NOT_FOUND;
+}
+
+sub css_handler {
+ my ($this, $req, $resp) = @_;
+ (my $path = $req->uri->path) =~ s|^/css/||;
+ my $content = static_file('css/'.$path);
+
+ if (defined $content) {
+ $resp->header('Content-Type' => 'text/css; charset=UTF-8');
+ $resp->content($content);
+ return RC_OK;
+ }
+ else {
+ return notfound_handler(@_);
+ }
+}
+
+sub internal_server_error_handler {
+ my ($this, $req, $resp, $error) = @_;
+
+ my $style = {
+ -style => 'white-space: pre;',
+ };
+
+ my $html = join '',
+ start_html(
+ -title => 'Internal Server Error',
+ -encoding => 'UTF-8',
+ ),
+ h1('Internal Server Error'),
+ h2('Request'),
+ p($style, $req->as_string),
+ h2('Error'),
+ p($style, $error),
+ end_html;
+
+ $resp->code(RC_INTERNAL_SERVER_ERROR);
+ $resp->message(status_message($resp->code));
+ $resp->header('Content-Type' => 'text/html; charset=UTF-8');
+ $resp->content($html);
+ return RC_INTERNAL_SERVER_ERROR;
+}
+
+sub redirect_handler {
+ # $req : HTTP::Request
+ # $resp: HTTP::Response
+ # $path: destination of the redirection
+ # $query_hash: query (can be undef)
+ my ($this, $req, $resp, $path, $query_hash) = @_;
+
+ $resp->header(Location => do {
+ my $uri = $req->uri->clone;
+ $uri->path($path);
+ $uri->query(undef);
+ $query_hash and
+ $uri->query_form_hash($query_hash);
+ $uri->fragment(undef);
+ $uri->as_string;
+ });
+ return RC_SEE_OTHER;
+}
+
+1;
--- /dev/null
+# -*- cperl -*-
+package POE::Component::IRC::Plugin::NoPaste::Httpd::Index;
+use strict;
+use warnings;
+use POE;
+use POE::Component::IRC::Plugin::NoPaste::Httpd;
+use POE::Component::IRC::Plugin::NoPaste::StaticFile;
+use POE::Component::IRC::Plugin::NoPaste::Pager;
+use URI::QueryParam;
+use Locale::TextDomain qw(pci-nopaste);
+use HTTP::Status;
+use Socket;
+use Time::Format qw(%time);
+use Encode qw(from_to);
+use constant NICK_LIMIT => 20;
+use constant TITLE_LIMIT => 100;
+use constant BODY_LIMIT => 500 * 1024;
+
+sub handler {
+ my ($this, $req, $resp) = @_;
+
+ if ($req->uri->path =~ m!^/nopaste/(.+?)/?$! and
+ $this->{nopaste}{id_to_channel}{$1}) {
+ return index_handler(
+ $this, $req, $resp, $this->{nopaste}{id_to_channel}{$1});
+ }
+ elsif ($req->uri->path =~ m!^/post/(.+?)/?$! and
+ $this->{nopaste}{id_to_channel}{$1}) {
+ return post_handler(
+ $this, $req, $resp, $this->{nopaste}{id_to_channel}{$1});
+ }
+ else {
+ return notfound_handler(@_);
+ }
+}
+
+sub index_handler {
+ my ($this, $req, $resp, $ch, $error) = @_;
+
+ local $ENV{LANGUAGE} = $ch->{locale};
+
+ my $t = POE::Component::IRC::Plugin::NoPaste::Template->new(
+ -data => static_file('tmpl/index.html'));
+
+ $t->expand(
+ lang => $ch->{locale},
+ title => "NoPaste :: $ch->{name}",
+ );
+
+ my ($ptr) = gethostbyaddr(
+ inet_aton($req->{connection}->remote_ip), AF_INET);
+ my @writable = $this->{nopaste}->pickup_writable($ch->{id}, $ptr);
+ my @readable = $this->{nopaste}->pickup_readable($ch->{id}, $ptr);
+
+ if (@writable or $ch->{restriction}{write} eq 'any') {
+ if ($error) {
+ $_ = $error;
+ s!\n!<br />!g;
+ $t->writable->error->add(error => $_);
+ }
+
+ $t->writable->expand(
+ channel_id => $ch->{id},
+ l18n_name => __"Name",
+ );
+
+ if ($ch->{restriction}{write} ne 'any') {
+ if (@writable ==1) {
+ $t->writable->restricted->only_one->add(
+ nick => $writable[0],
+ );
+ }
+ else {
+ foreach my $nick (@writable) {
+ $t->writable->restricted->multiple->entry->add(
+ nick => $nick,
+ );
+ }
+ $t->writable->restricted->multiple->add;
+ }
+ $t->writable->restricted->add;
+ }
+ else {
+ $t->writable->not_restricted->add;
+ }
+
+ $t->writable->add(
+ l18n_title => __"Title",
+ l18n_body => __(
+ # body of the post
+ "Body",
+ ),
+ l18n_paste => __"Paste",
+ );
+
+ # set the default values
+ my $q = $req->uri->clone;
+ if (not $q->query_param('nick') and @writable == 1) {
+ $q->query_param(nick => $writable[0]);
+ }
+ $t->setform($q => 'post');
+ }
+ else {
+ my $msg = $this->{nopaste}->gen_unwritable_error($ch);
+ $msg =~ s!\n!<br />!g;
+
+ $t->not_writable->add(
+ error => $msg,
+ );
+ }
+
+ if (@readable or $ch->{restriction}{read} eq 'any') {
+ my $pager = POE::Component::IRC::Plugin::NoPaste::Pager->new(
+ fetch => {
+ sql => q{
+ SELECT *
+ FROM post
+ WHERE channel_id = ?
+ ORDER BY posted_time DESC
+ },
+ placeholder => [$ch->{id}],
+ dbh => $this->{nopaste}{db}->dbh,
+ },
+ page_to_show => scalar $req->uri->query_param('page'),
+ pagenums_limit => 20,
+ items_per_page => 20,
+ show_meta => sub {
+ my %meta = @_;
+
+ if ($meta{page} == 1) {
+ $t->readable->prev->nolink->add;
+ }
+ else {
+ $t->readable->prev->link->add(
+ page => $meta{page} - 1,
+ );
+ }
+ $t->readable->prev->add;
+
+ foreach my $i ($meta{pagelink_begin} .. $meta{pagelink_end}) {
+ if ($i == $meta{page}) {
+ $t->readable->pages->page->nolink->add(
+ page => $i,
+ );
+ }
+ else {
+ $t->readable->pages->page->link->add(
+ page => $i,
+ );
+ }
+ $t->readable->pages->page->add;
+ }
+ $t->readable->pages->add;
+
+ if ($meta{page} == $meta{last_page}) {
+ $t->readable->next->nolink->add;
+ }
+ else {
+ $t->readable->next->link->add(
+ page => $meta{page} + 1,
+ );
+ }
+ $t->readable->next->add;
+ },
+ show_content => sub {
+ my $row = shift;
+
+ $t->readable->list_data->add(
+ id => $row->{post_id},
+ title => $row->{title},
+ name => $row->{nick},
+ body => $row->{body},
+ timestamp => $time{'yyyy-mm-dd hh:mm:ss', $row->{posted_time}},
+ );
+ },
+ no_content => sub {
+ $t->readable->list_nodata->add(
+ l18n_nodata => __"There are no entries currently.",
+ );
+ },
+ );
+ $pager->execute;
+
+ $t->readable->add(
+ l18n_title => __"Title",
+ l18n_name => __"Name",
+ l18n_timestamp => __"Time Stamp",
+ );
+ }
+ else {
+ my $msg = $this->{nopaste}->gen_unreadable_error($ch);
+ $msg =~ s!\n!<br />!g;
+
+ $t->not_readable->add(
+ error => $msg,
+ );
+ }
+
+ $resp->content($t->str);
+ return RC_OK;
+}
+
+sub post_handler {
+ my ($this, $req, $resp, $ch) = @_;
+ my $nick = $req->uri->query_param('nick');
+ my $title = $req->uri->query_param('title');
+ my $body = $req->uri->query_param('body');
+
+ local $ENV{LANGUAGE} = $ch->{locale};
+
+ my @error;
+ if (not defined $nick or not length $nick) {
+ push @error, __"Please don't omit your name.";
+ }
+ elsif (length($nick) > NICK_LIMIT) {
+ push @error, __x("Please shorten your name up to {n} bytes.", n => NICK_LIMIT);
+ }
+ if (not defined $title or not length $title) {
+ push @error, __"Please don't omit the title.";
+ }
+ elsif (length($title) > TITLE_LIMIT) {
+ push @error, __x("Please shorten the title up to {n} bytes.", n => TITLE_LIMIT);
+ }
+ if (not defined $body or not length $body) {
+ push @error, __"Please don't omit the body.";
+ }
+ elsif (length($body) > BODY_LIMIT) {
+ push @error, __x("Please shorten the body up to {n} bytes.", n => BODY_LIMIT);
+ }
+
+ if (@error) {
+ return index_handler($this, $req, $resp, $ch, join("\n", map {"* $_"} @error));
+ }
+
+ my ($ptr) = gethostbyaddr(
+ inet_aton($req->{connection}->remote_ip), AF_INET);
+ my @writable = $this->{nopaste}->pickup_writable($ch->{id}, $ptr);
+ if ($ch->{restriction}{write} eq 'any' or
+ grep {$_ eq $nick} @writable) {
+
+ my $db = $this->{nopaste}{db};
+
+ # check for duplication
+ if ($db->dbh->selectrow_hashref(q{
+ SELECT *
+ FROM post
+ WHERE channel_id = ? AND nick = ? AND
+ title = ? AND body = ?
+ }, undef, $ch->{id}, $nick, $title, $body)) {
+ return index_handler(
+ $this, $req, $resp, $ch, __"A duplicated entry is being pasted.");
+ }
+
+ # insert it
+ $db->dbh->do(q{
+ INSERT INTO post
+ (channel_id, posted_time, nick, title, body)
+ VALUES (? , ? , ? , ? , ? )
+ }, undef, $ch->{id}, time, $nick, $title, $body);
+
+ # get the post id
+ my ($post_id) = $db->dbh->selectrow_array(q{
+ SELECT LAST_INSERT_ROWID()});
+
+ # announce it in the channel
+ my $name = $ch->{name};
+ from_to $name, 'UTF-8' => $ch->{charset};
+
+ my @msg = (
+ __x("{nick} pasted an entry: {title}", nick => $nick, title => $title),
+ do {
+ my $uri = $req->uri->clone;
+ $uri->path("/pasted/$post_id");
+ $uri->query(undef);
+ $uri->fragment(undef);
+ $uri->as_string;
+ },
+ );
+ foreach (@msg) {
+ my $line = $_;
+ from_to $line, 'UTF-8' => $ch->{charset};
+
+ $this->{nopaste}{irc}->yield(
+ notice => $name => $line);
+ }
+
+ # redirect to the index
+ return redirect_handler(
+ $this, $req, $resp, "/nopaste/$ch->{id}/");
+ }
+ else {
+ return index_handler($this, $req, $resp, $ch);
+ }
+}
+
+1;
--- /dev/null
+# -*- cperl -*-
+package POE::Component::IRC::Plugin::NoPaste::Httpd::Pasted;
+use strict;
+use warnings;
+use POE;
+use POE::Component::IRC::Plugin::NoPaste::Httpd;
+use POE::Component::IRC::Plugin::NoPaste::StaticFile;
+use Locale::TextDomain qw(pci-nopaste);
+use HTTP::Status;
+use Socket;
+use Time::Format qw(%time);
+use Encode qw(from_to);
+
+sub handler {
+ my ($this, $req, $resp) = @_;
+
+ if ($req->uri->path =~ m!^/pasted/(\d+)$!) {
+ return pasted_handler(
+ $this, $req, $resp, $1);
+ }
+ else {
+ return notfound_handler(@_);
+ }
+}
+
+sub pasted_handler {
+ my ($this, $req, $resp, $post_id) = @_;
+
+ # check for the existence of line in db
+ my $post = $this->{nopaste}{db}->dbh->selectrow_hashref(q{
+ SELECT *
+ FROM post
+ WHERE post_id = ?
+ }, undef, $post_id);
+
+ if (not $post) {
+ return notfound_handler(@_);
+ }
+
+ # is the channel_id still defined?
+ my $ch = $this->{nopaste}{id_to_channel}{$post->{channel_id}};
+ if (not $ch) {
+ # no. probably there should be some way to change channel_id.
+ return notfound_handler(@_);
+ }
+
+ my $escape = sub {
+ $_ = shift;
+ s!&!&!g;
+ s!<!<!g;
+ s!>!>!g;
+ $_;
+ };
+
+ local $ENV{LANGUAGE} = $ch->{locale};
+
+ my $t = POE::Component::IRC::Plugin::NoPaste::Template->new(
+ -data => static_file('tmpl/pasted.html'));
+
+ $t->expand(
+ lang => $ch->{locale},
+ title => $escape->("NoPaste :: $ch->{name}"),
+ );
+
+ my ($ptr) = gethostbyaddr(
+ inet_aton($req->{connection}->remote_ip), AF_INET);
+ my @readable = $this->{nopaste}->pickup_readable($ch->{id}, $ptr);
+
+ if (@readable or $ch->{restriction}{read} eq 'any') {
+ # we want to know which are the next and the previous posts.
+ my $prev = $this->{nopaste}{db}->dbh->selectrow_hashref(q{
+ SELECT *
+ FROM post
+ WHERE channel_id = ? AND posted_time > ?
+ LIMIT 1
+ }, undef, $ch->{id}, $post->{posted_time});
+ my $next = $this->{nopaste}{db}->dbh->selectrow_hashref(q{
+ SELECT *
+ FROM post
+ WHERE channel_id = ? AND posted_time < ?
+ LIMIT 1
+ }, undef, $ch->{id}, $post->{posted_time});
+
+ if ($prev) {
+ $t->readable->prev->add(
+ id => $prev->{post_id},
+ pasted_by => __x(
+ "Pasted by {name}", name => $escape->($prev->{nick})),
+ title => $escape->($prev->{title}),
+ );
+ }
+ $t->readable->expand(
+ channel_id => $ch->{id},
+ l18n_index => __"Index",
+ );
+ if ($next) {
+ $t->readable->next->add(
+ id => $next->{post_id},
+ pasted_by => __x(
+ "Pasted by {name}", name => $escape->($next->{nick})),
+ title => $escape->($next->{title}),
+ );
+ }
+
+ $t->readable->add(
+ l18n_name => __"Name",
+ name => $escape->($post->{nick}),
+ l18n_title => __"Title",
+ title => $escape->($post->{title}),
+ l18n_body => __"Body",
+ body => $escape->($post->{body}),
+ );
+ }
+ else {
+ my $msg = $this->{nopaste}->gen_unreadable_error($ch);
+ $msg =~ s!\n!<br />!g;
+
+ $t->not_readable->add(
+ error => $msg,
+ );
+ }
+
+ $resp->content($t->str);
+ return RC_OK;
+}
+
+1;
--- /dev/null
+# -*- cperl -*-
+package POE::Component::IRC::Plugin::NoPaste::Pager;
+use strict;
+use warnings;
+use Carp;
+use UNIVERSAL qw(isa);
+use Error qw(:try);
+use Hash::Util qw(lock_keys);
+our $VERSION = '0.1';
+
+=pod
+
+ my $pager = Pager->new(
+ # 目的のデータを取り出す方法。
+ # SQL文を使用する場合:
+ fetch => {
+ sql => q{SELECT foo, bar FROM foo WHERE bar=? AND baz=?},
+ placeholder => [100, 200],
+ dbh => $dbh,
+ },
+ # CODEを使用する場合:
+ fetch => {
+ code => sub {
+ # $begin: 表示を開始する項目の番號(0オリジン)
+ # $length: 表示する項目の個數
+ # $code_show: 表面的には、show_contentで指定された關數(内部的には違ふ)
+ my ($begin, $length, $code_show) = @_;
+ for ($begin .. ($begin + $length - 1)) {
+ $code_show->("Item [$_]");
+ }
+ },
+ },
+ # 全項目數を知る方法。
+ # fetchがSQL文であるなら、countを省略すれば
+ # 自動的にSELECT COUNT(*)文をfetchのSQLから生成する。
+ count => {
+ sql => q{SELECT COUNT(*) FROM foo WHERE bar=? AND baz=?},
+ placeholder => [100, 200],
+ dbh => $dbh,
+ },
+ # 若しくは
+ count => {
+ code => sub {
+ return 100;
+ },
+ },
+ page_to_show => 2, # 表示したいページ(1オリジン); デフォルトは1
+ pagenums_limit => 10, # 各ページへのリンクの最大表示個數; デフォルトは10
+ items_per_page => 20, # ページ毎の項目の最大表示數; デフォルトは20
+ # メタ情報が得られた時に呼ばれる關數。
+ show_meta => sub {
+ # 番號は全て1オリジン。
+ # total: 総件數
+ # page: 現在のページ番號
+ # last_page: 最終ページ番號
+ # pagelink_begin: 各ページへのリンクの開始ページ番號
+ # pagelink_end: 各ページへのリンクの終了ページ番號(この番號も含む)
+ my %meta = @_;
+ print "page: $meta{page}/$meta{last_page}; total: $meta{total}\n";
+ },
+ # 項目が得られた時に呼ばれる關數。
+ show_content => sub {
+ # fetchがSQL文なら、$_[0]はfetchrow_hashrefで得られたハッシュ。
+ # CODEなら、そのCODEの中から明示的に呼ばれなければならない。
+ print "item: $_[0]\n";
+ },
+ # 項目が一つも無い時に呼ばれる關數。省略可。
+ no_content => sub {
+ # do what you want to
+ },
+ );
+ $pager->execute;
+
+=cut
+
+sub new {
+ my ($class, %args) = @_;
+
+ my $fetch = $args{fetch};
+ if (!isa $fetch, 'HASH') {
+ croak "Arg{fetch} is not a hashref";
+ }
+ if (defined $fetch->{sql}) {
+ $fetch->{dbh} or croak "Arg{fetch} has a sql, but not dbh";
+ $fetch->{code} and croak "Arg{fetch} has both of sql and code";
+ # FIXME: LIMITが付いてゐたらcroak
+ }
+ elsif (defined $fetch->{code}) {
+ (isa $fetch->{code}, 'CODE') or croak "Arg{fetch}{code} is not a coderef: ".$fetch->{code};
+ $fetch->{sql} and croak "Arg{fetch} has both of sql and code";
+ }
+
+ my $count = $args{count};
+ if (!defined $count) {
+ if (defined $fetch->{sql}) {
+ # fetchのSQL文を改造して作る。
+ (my $sql = $fetch->{sql}) =~ s/^\s*select\s+(.+?)\s+from/select count(*) from/i;
+ $count = $args{count} = {};
+ $count->{sql} = $sql;
+ $count->{placeholder} = $fetch->{placeholder} if $fetch->{placeholder};
+ $count->{dbh} = $fetch->{dbh};
+ }
+ else {
+ croak "Arg{count} cannot be omitted when the Arg{fetch} is not a SQL";
+ }
+ }
+ elsif (!isa $count, 'HASH') {
+ croak "Arg{count} is not a hashref";
+ }
+ # FIXME: $args{count}のsanity checkを（もっと）
+
+ # FIXME: 以下の三つの變數をsanity check
+ $args{page_to_show} ||= 1;
+ $args{pagenums_limit} ||= 10;
+ $args{items_per_page} ||= 20;
+
+ foreach my $key (qw/show_meta show_content/) {
+ if (!defined $args{$key}) {
+ croak "Missing Arg{$key}";
+ }
+ elsif (!isa $args{$key}, 'CODE') {
+ croak "Arg{$key} is not a coderef: $args{$key}";
+ }
+ }
+
+ if (defined $args{no_content} and
+ !isa $args{no_content}, 'CODE') {
+ croak "Arg{no_content} is not a coderef: $args{no_content}";
+ }
+ $args{no_content} ||= undef;
+
+ my $this = bless \%args => $class;
+ lock_keys %$this;
+ $this;
+}
+
+sub ceil {
+ my $val = $_[0];
+ my $floor = int($val);
+ $floor == $val ? $floor : $floor + 1;
+}
+
+sub min {
+ my $min = $_[0];
+ foreach (@_) {
+ $min = $_ if $min > $_;
+ }
+ $min;
+}
+
+sub max {
+ my $max = $_[0];
+ foreach (@_) {
+ $max = $_ if $max < $_;
+ }
+ $max;
+}
+
+sub execute {
+ my $this = shift;
+
+ my $count;
+ if (defined $this->{count}{sql}) {
+ try {
+ $count = $this->{count}{dbh}->selectrow_array(
+ $this->{count}{sql}, undef, @{$this->{count}{placeholder} || []});
+ } otherwise {
+ throw Error::Simple "Failed to do count by sql: $_[0]";
+ };
+ }
+ else {
+ try {
+ $count = $this->{count}{code}->();
+ } otherwise {
+ throw Error::Simple "Failed to do count by code: $_[0]";
+ };
+ }
+
+ # この情報を基に、メタデータを生成
+ my $last_page = max(1, ceil($count / $this->{items_per_page}));
+ my $page = min($this->{page_to_show}, $last_page);
+ my $pagelink_begin = max(1, int($page - $this->{pagenums_limit} / 2));
+ my $pagelink_end = min($last_page, $pagelink_begin + $this->{pagenums_limit} - 1);
+
+ # show_metaを呼ぶ
+ $this->{show_meta}->(
+ count => $count,
+ page => $page,
+ last_page => $last_page,
+ pagelink_begin => $pagelink_begin,
+ pagelink_end => $pagelink_end);
+
+ # fetch實行
+ my $fetch_begin = ($page - 1) * $this->{items_per_page};
+ my $fetch_length = min($count - $fetch_begin,
+ $this->{items_per_page});
+ if (defined $this->{fetch}{sql}) {
+ try {
+ # FIXME: これより増しなLIMIT生成方法を
+ my $sql = $this->{fetch}{sql} . " LIMIT $fetch_begin, $fetch_length";
+
+ my $sth = $this->{fetch}{dbh}->prepare($sql);
+ $sth->execute(@{$this->{fetch}{placeholder} || []});
+ while ($_ = $sth->fetchrow_hashref) {
+ $this->{show_content}->($_);
+ }
+ if ($sth->rows == 0) {
+ $this->{no_content} and
+ $this->{no_content}->();
+ }
+ } otherwise {
+ throw Error::Simple "Failed to do fetch by sql: $_[0]";
+ };
+ }
+ else {
+ # $fetch_length囘呼ばれたかどうかをチェックする
+ my $called_count = 0;
+ my $checked_show = sub {
+ $called_count++;
+ goto &{$this->{show_content}};
+ };
+ try {
+ $this->{fetch}{code}->(
+ $fetch_begin, $fetch_length, $checked_show);
+ } otherwise {
+ throw Error::Simple "Failed to do fetch by code: $_[0]";
+ };
+ if ($called_count != $fetch_length) {
+ carp "Fetch coderef didn't call show_content exactly $fetch_length times (call \$length($fetch_length) times)";
+ }
+ if ($fetch_length == 0) {
+ $this->{no_content} and
+ $this->{no_content}->();
+ }
+ }
+
+ $this;
+}
+
+1;
--- /dev/null
+# -*- cperl -*-
+# -----------------------------------------------------------------------------
+package POE::Component::IRC::Plugin::NoPaste::StaticFile;
+use strict;
+use warnings;
+use File::Spec;
+use File::stat;
+require Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT = qw(&static_file);
+
+# path => [lastmod, content]
+my $TABLE = {};
+
+sub static_file {
+ my ($path) = @_;
+ my $fullpath;
+
+ foreach my $inc (@INC) {
+ my $fpath = File::Spec->canonpath(
+ File::Spec->catdir(
+ File::Spec->splitdir($inc),
+ qw(POE Component IRC Plugin NoPaste),
+ File::Spec->splitdir($path)));
+
+ if (-r $fpath) {
+ $fullpath = $fpath;
+ last;
+ }
+ }
+ defined $fullpath or return undef;
+
+ my $lastmod = stat($fullpath)->mtime;
+
+ my $entry = $TABLE->{$fullpath};
+ if (!$entry or $entry->[0] < $lastmod) {
+ local $/ = undef;
+ open my $fh, '<', $fullpath;
+ my $content = <$fh>;
+ close $fh;
+
+ $entry = $TABLE->{$fullpath} = [$lastmod, $content];
+ }
+
+ return $entry->[1];
+}
+
+1;
--- /dev/null
+# -*- cperl -*-
+# -----------------------------------------------------------------------------
+package POE::Component::IRC::Plugin::NoPaste::Template;
+use strict;
+use warnings;
+use Carp;
+use UNIVERSAL;
+our $AUTOLOAD;
+our $VERSION = 2;
+
+our $SETFORM_SUPPORTED = 1;
+BEGIN {
+ eval q{ use URI; use URI::QueryParam; };
+ $@ and $SETFORM_SUPPORTED = 0;
+}
+
+=head1 NAME
+
+ Template - Text Template Class (especially for (x)html)
+
+=head1 SYNOPSIS
+
+ ### sample.html ###
+
+ <html>
+ <head>
+ <title>Sample Page - <t-tag:embed> - Sample Page</title>
+ </head>
+ <body>
+ <p>
+ <t-block:block>
+ line: <t-tag:foo><br>
+ </t-block:block>
+ </p>
+ </body>
+ </html>
+
+
+ ### sample.pl ###
+
+ use Template;
+ my $t = Template->new(
+ -fpath => './sample.html',
+ );
+ $t->expand(
+ embed => 'EMBED TITLE',
+ );
+ foreach (1 .. 3) {
+ $t->block->add(
+ foo => ".: $_ :.",
+ );
+ }
+ print $t->str;
+
+
+ ### output ###
+
+ <html>
+ <head>
+ <title>Sample Page - EMBED TITLE - Sample Page</title>
+ </head>
+ <body>
+ <p>
+
+ line: 1<br>
+
+ line: 2<br>
+
+ line: 3<br>
+
+ </p>
+ </body>
+ </html>
+
+=head1 DESCRIPTION
+
+not available yet...
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item $t = Template->new( %args );
+
+=over 8
+
+=item -fpath => file to use as template (one of this and -data is required)
+
+=item -data => data to use as template
+
+=item -strip => whether delete newlines after <!begin>, <!end> or not
+
+=item -lang => language to output
+
+Any blocks surrounded by <t-lang:...> and </t-lang:...> are treated as
+language specific block.
+
+ e.g.
+
+ <t-lang:default> This is default </t-lang:default>
+ <t-lang:ja> Nihongo(Japanese) </t-lang:ja>
+
+ my $t = Template->new(
+ -fpath => './foo.html',
+ -lang => 'ja');
+ print $t->str; # this shows "Nihongo(Japanese)"
+
+ $t = Template->new(
+ -fpath => './foo.html',
+ -lang => 'en');
+ print $t->str; # this shows "This is default"
+
+=back
+
+=back
+
+=cut
+
+sub new {
+ # %args = (
+ # -fpath => テンプレートとして使用するファイル
+ # -data => テンプレートとして使用するデータ
+ # -strip => <!begin>や<!end>の直後の改行を削除するかどうか,
+ # -lang => 言語名,
+ # )
+ my ($class, %args) = @_;
+ my $this = {
+ original => undef, # リーフを<!mark:foo>に置換した中身。
+ current => undef, # <&foo>を置換した後のもの。
+ leaves => {}, # {名前 => Template}
+ parent => undef, # これがトップレベルでなければ、親(Template)。
+ leafname => undef, # これがトップレベルでなければ、リーフ名。
+ };
+ bless $this => $class;
+
+ my $source;
+ if (defined $args{-fpath}) {
+ if (defined $args{-data}) {
+ croak "You can't specify both of -fpath and -data at the same time.\n";
+ }
+ local $/ = undef;
+ open my $fh, '<', $args{-fpath}
+ or croak "Failed to open file $args{-fpath}";
+ $source = <$fh>;
+ close($fh);
+ }
+ elsif (defined $args{-data}) {
+ $source = $args{-data};
+ }
+ else {
+ croak "Missing both of -fpath and -data. Read `perldoc Template'\n";
+ }
+
+ # <t-block:*>や<t-lang:*>の直後が改行コードなら、それを消す。
+ # その改行コードから始まるスペースまたはタブも、インデントと見做して消す。
+ if ($args{-strip}) {
+ $source =~ s{(</?t-block:.+?>|</?t-lang:.+?>)\x0d?\x0a[ \t]*}{$1}g;
+ }
+
+ # 言語
+ my $lang = 'default';
+ if ($args{-lang} and $source =~ m/<t-lang:\Q$args{-lang}\E>/) {
+ $lang = $args{-lang};
+ }
+ $source =~ s{<t-lang:(.+?)>(.+?)</t-lang:\1>}{
+ if ($1 eq $lang) {
+ $2;
+ }
+ else {
+ '';
+ }
+ }seg;
+
+ $this->_load($source);
+ $this;
+}
+
+sub reset {
+ my $this = shift;
+ $this->{current} = $this->{original};
+ $this;
+}
+
+sub expand {
+ # $t->expand({foo => '---' , bar => '+++'});
+ # もしくは
+ # $t->expand(foo => '---' , bar => '+++');
+
+ # このメソッドは、キー内に現われたアンダースコアを
+ # ハイフンにフォールバックする事が出來る。
+ # つまり、<t-tag:foo-bar>というタグを、キー名"foo_bar"で指定する事が出來る。
+ my $this = shift;
+ my $hash = do {
+ if (@_ == 1 && UNIVERSAL::isa($_[0],'HASH')) {
+ $_[0];
+ }
+ elsif (@_ % 2 == 0) {
+ my %h = @_;
+ \%h;
+ }
+ else {
+ croak "Illegal argument for Template->expand";
+ }
+ };
+ while (my ($key,$value) = each %$hash) {
+ # $key,$value共にスカラー値でなければならない。
+ # リファならエラー。
+ if (!defined $value) {
+ croak "Values must not be undef; key: $key";
+ }
+ if (ref($key) ne '') {
+ croak "Keys and values must be scalar values: $key";
+ }
+ if (ref($value) ne '') {
+ croak "Keys and values must be scalar values: $value";
+ }
+
+ if ($this->{current} !~ s|<t-tag:\Q$key\E(?:\s*/)?>|$value|g) {
+ # 無い。アンダースコアをハイフンに変えてみる。
+ (my $tred_key = $key) =~ tr/_/-/;
+ if ($this->{current} !~ s|<t-tag:\Q$tred_key\E(?:\s*/)?>|$value|g) {
+ # そのようなキーは存在しなかった。警告。
+ #carp "No <t-tag:$key> are in template, or you have replaced it already";
+ }
+ }
+ }
+ $this;
+}
+
+sub add {
+ my $this = shift;
+
+ # 引数があればexpandする。
+ if (@_ > 0) {
+ eval {
+ $this->expand(@_);
+ }; if ($@) {
+ croak $@;
+ }
+ }
+
+ # 親が存在しなければcroak。
+ if (!defined $this->{parent}) {
+ croak "This template doesn't have its parent.";
+ }
+
+ # 親の<t-mark:foo>の直前に、このリーフを挿入。
+ my $str = $this->str;
+ $this->{parent}{current} =~ s|(<t-mark:\Q$this->{leafname}\E(?:\s*/)?>)|$str$1|g;
+
+ # リセット
+ $this->reset;
+
+ $this;
+}
+
+sub str {
+ my $this = shift;
+ my $result = $this->{current};
+
+ # 未置換の<t-tag:foo>があればそれを消してcarp。
+ while ($result =~ s/(<t-tag:.+?>)//) {
+ carp "Unexpanded tag: $1";
+ }
+
+ # <t-mark:foo>を消す。
+ $result =~ s/<t-mark:.+?>//g;
+
+ $result;
+}
+
+sub leaf {
+ my ($this,$leafname) = @_;
+ $this->{leaves}{$leafname};
+}
+
+sub AUTOLOAD {
+ my $this = shift;
+ (my $leafname = $AUTOLOAD) =~ s/.+?:://g;
+
+ # 余分な引數が付いてゐれば、恐らくこれは關數名の誤り。
+ if (@_) {
+ croak "Calling autoloaded Template->$leafname with extra arguments must be a mistake";
+ }
+
+ # アンダースコアはハイフンに置換。
+ $leafname =~ tr/_/-/;
+ $this->{leaves}{$leafname};
+}
+
+sub _new_leaf {
+ my ($class,$parent,$leafname,$source) = @_;
+ my $this = {
+ original => undef,
+ current => undef,
+ leaves => {},
+ parent => $parent,
+ leafname => $leafname,
+ };
+ bless $this,$class;
+
+ $this->_load($source);
+}
+
+sub _load {
+ my ($this,$source) = @_;
+
+ # <t-block:foo> ... </t-block:foo>を<t-mark:foo>に置換しつつ、そのリーフを保存。
+ while ($source =~ s|<t-block:(.+?)>(.+?)</t-block:\1>|<t-mark:$1>|s) {
+ my ($leafname,$source) = ($1,$2);
+
+ if (defined $this->{leaves}{$leafname}) {
+ # 既にこのリーフが定義されていたらcroak。
+ croak "duplicated leaves in template: $leafname";
+ }
+ else {
+ $this->{leaves}{$leafname} = __PACKAGE__->_new_leaf($this,$leafname,$source);
+ }
+ }
+ $this->{original} = $this->{current} = $source;
+
+ $this;
+}
+
+sub escape_tag {
+ my @args = @_;
+ my @result;
+ foreach my $str (@args) {
+ if (defined $str) {
+ $str =~ s/\&/\&/g;
+ $str =~ s/</\</g;
+ $str =~ s/>/\>/g;
+ $str =~ s/\"/\"/g;
+ }
+ push @result, $str;
+ }
+ wantarray ? @result : $result[0];
+}
+
+sub unescape_tag {
+ my @args = @_;
+ my @result;
+ foreach my $str (@args) {
+ if (defined $str) {
+ $str =~ s/\</</g;
+ $str =~ s/\>/>/g;
+ $str =~ s/\"/\"/g;
+ $str =~ s/\&/\&/g;
+ }
+ push @result, $str;
+ }
+ wantarray ? @result : $result[0];
+}
+
+sub html2tag {
+ my $tag = {};
+ $_ = shift;
+
+ s|^<||;
+ s|^(/?\w+)|| and $tag->{__top} = lc $1;
+
+ while (1) {
+ s|([\w\-]+)=([\"\'])(.*?)\2|| and do {
+ $tag->{lc $1} = $3;
+ next;
+ };
+ s|([\w\-]+)=([^\s\>]+)|| and do {
+ $tag->{lc $1} = $2;
+ next;
+ };
+ s,(\w+|/),, and do {
+ $tag->{__end} = lc $1;
+ next;
+ };
+ last;
+ }
+
+ my $new = {};
+ foreach (keys %$tag) {
+ $new->{unescape_tag($_)} = unescape_tag($tag->{$_});
+ }
+ $new;
+}
+
+sub tag2html {
+ my $tag = shift;
+
+ my $html;
+ $html .= '<' . $tag->{__top};
+ foreach (keys %$tag) {
+ /^__/ and next;
+ $html .= sprintf ' %s="%s"', escape_tag($_), escape_tag($tag->{$_});
+ }
+ defined $tag->{__end} and
+ $html .= ' ' . $tag->{__end};
+
+ $html .= '>';
+ $html;
+}
+
+sub setform {
+ # $uri: URI
+ my ($this, $uri, $name) = @_;
+ defined $name or $name = '';
+
+ if (!UNIVERSAL::isa($uri, 'URI')) {
+ croak "Usage: Template->setform(URI [, name])";
+ }
+
+ $SETFORM_SUPPORTED or
+ croak "Install URI::QueryParam to enable setform";
+
+ my $is_xhtml = ($this->{current} =~ m|^\s*<\?xml|);
+
+ my $outhtml = '';
+ my $in_select; # name
+ my $in_select_option_tag; # tag
+ my $in_textarea; # name
+ my $in_form = ''; # name
+ foreach (split /(<[^\<\>]+?>)/, $this->{current}) {
+ if (defined $in_select and defined $in_select_option_tag) {
+ my $value = '';
+ /^([^ \<\r\n]*)/i and $value = $1;
+
+ my $tag = $in_select_option_tag;
+ if (grep {$value eq $_} $uri->query_param($in_select)) {
+ $tag->{$is_xhtml ? 'selected' : '__end'} = 'selected';
+ }
+ else {
+ delete $tag->{$is_xhtml ? 'selected' : '__end'};
+ }
+
+ $outhtml .= tag2html($tag);
+ undef $in_select_option_tag;
+ }
+ if (defined $in_textarea) {
+ if (!m|^</textarea>|i) {
+ next;
+ }
+ }
+
+ my $taghtml = $_;
+ if (!/^</) {
+ $outhtml .= $_;
+ next;
+ }
+
+ my $tag = html2tag($taghtml);
+ if (!defined $tag->{__top}) {
+ $outhtml .= $taghtml;
+ }
+ elsif ($tag->{__top} eq 'form') {
+ if (defined($_ = $tag->{name})) {
+ $in_form = unescape_tag($_);
+ }
+ else {
+ $in_form = '';
+ }
+
+ if (!$tag->{action}) {
+ my $act = $uri->clone;
+ $act->query(undef);
+ $act->fragment(undef);
+ $tag->{action} = $act->canonical->as_string;
+ }
+
+ $outhtml .= tag2html($tag);
+ }
+ elsif ($name ne $in_form) {
+ $outhtml .= $taghtml;
+ }
+ elsif ($tag->{__top} eq 'input') {
+ if (defined $tag->{name}) {
+ my $type = $tag->{type};
+ if (!$type or
+ grep {$_ eq $type} qw[text password hidden submit]) {
+ if (defined(my $value = $uri->query_param($tag->{name}))) {
+ $tag->{value} = $value;
+ }
+ $outhtml .= tag2html($tag);
+ }
+ elsif (grep {$_ eq $type} qw[radio checkbox]) {
+ if (defined $tag->{value} and
+ grep {$_ eq $tag->{value}}
+ $uri->query_param($tag->{name})) {
+ $tag->{$is_xhtml ? 'checked' : '__end'} = 'checked';
+ }
+ else {
+ delete $tag->{$is_xhtml ? 'checked' : '__end'};
+ }
+ $outhtml .= tag2html($tag);
+ }
+ else {
+ $outhtml .= $taghtml;
+ }
+ }
+ else {
+ $outhtml .= $taghtml;
+ }
+ }
+ elsif ($tag->{__top} eq 'textarea') {
+ if (defined($_ = $tag->{name})) {
+ $in_textarea = $_;
+ $outhtml .= tag2html($tag);
+ if (defined(my $value = $uri->query_param($_))) {
+ $outhtml .= escape_tag($value);
+ }
+ }
+ else {
+ $outhtml .= tag2html($tag);
+ }
+ }
+ elsif ($tag->{__top} eq '/textarea') {
+ $outhtml .= tag2html($tag);
+ undef $in_textarea;
+ }
+ elsif ($tag->{__top} eq 'select') {
+ if (defined($_ = $tag->{name})) {
+ $in_select = $_;
+ }
+ $outhtml .= tag2html($tag);
+ }
+ elsif ($tag->{__top} eq '/select') {
+ $outhtml .= tag2html($tag);
+ undef $in_select;
+ }
+ elsif (defined $in_select) {
+ if ($tag->{__top} eq 'option') {
+ if (defined(my $val = $tag->{value})) {
+ if (grep {$val eq $_} $uri->query_param($in_select)) {
+ $tag->{$is_xhtml ? 'selected' : '__end'} = 'selected';
+ }
+ else {
+ delete $tag->{$is_xhtml ? 'selected' : '__end'};
+ }
+ $outhtml .= tag2html($tag);
+ }
+ else {
+ $in_select_option_tag = $tag;
+ }
+ }
+ else {
+ $outhtml .= $taghtml;
+ }
+ }
+ else {
+ $outhtml .= $taghtml;
+ }
+ }
+
+ $this->{current} = $outhtml;
+}
+
+sub addhiddenform {
+ # $uri: URI or HASH
+ my ($this, $uri, $name) = @_;
+ defined $name or $name = '';
+
+ $SETFORM_SUPPORTED or
+ croak "Install URI::QueryParam to enable setform";
+
+ if (!UNIVERSAL::isa($uri, 'URI')) {
+ if (UNIVERSAL::isa($uri, 'HASH')) {
+ my $u = URI->new('', 'http');
+ while (my ($key, $value) = each %$uri) {
+ $u->query_param(
+ $key => UNIVERSAL::isa($value, 'ARRAY') ? @$value : $value);
+ }
+ $uri = $u;
+ }
+ else {
+ croak "\$uri was not URI nor HASH";
+ }
+ }
+
+ my $is_xhtml = ($this->{current} =~ m|^\s*<\?xml|);
+
+ my $outhtml = '';
+ foreach (split /(<[^\<\>]+?>)/, $this->{current}) {
+ my $taghtml = $_;
+ if (!/^</) {
+ $outhtml .= $_;
+ next;
+ }
+
+ my $tag = html2tag($taghtml);
+
+ if (defined $tag->{__top} and
+ $tag->{__top} eq 'form' and
+ !$tag->{action}) {
+ my $act = $uri->clone;
+ $act->query(undef);
+ $act->fragment(undef);
+ $tag->{action} = $act->canonical->as_string;
+
+ $outhtml .= tag2html($tag);
+ }
+ else {
+ $outhtml .= $taghtml;
+ }
+
+ if (defined $tag->{__top} and
+ $tag->{__top} eq 'form') {
+ if ((!defined $tag->{name} and $name eq '') or
+ (defined $tag->{name} and $name eq $tag->{name})) {
+ foreach my $key ($uri->query_param) {
+ my $format = $is_xhtml ?
+ q{<input type="hidden" name="%s" value="%s" />} :
+ q{<input type="hidden" name="%s" value="%s">};
+ $outhtml .= sprintf($format, $key, $uri->query_param($key));
+ }
+ }
+ }
+ }
+
+ $this->{current} = $outhtml;
+}
+
+sub disableform {
+ my ($this, $keylist, $name) = @_;
+ defined $name or $name = '';
+
+ my %keyhash = map {$_ => 1} @$keylist;
+
+ my $is_xhtml = ($this->{current} =~ m|^\s*<\?xml|);
+
+ my $outhtml = '';
+ my $in_textarea; # name
+ my $in_form = '';
+ foreach (split /(<[^\<\>]+?>)/, $this->{current}) {
+ my $taghtml = $_;
+ if (!/^</) {
+ $outhtml .= $_;
+ next;
+ }
+
+ if (defined $in_textarea) {
+ if (!m|^</textarea>|i) {
+ next;
+ }
+ }
+
+ my $tag = html2tag($taghtml);
+
+ if (!defined $tag->{__top}) {
+ $outhtml .= $taghtml;
+ }
+ elsif ($tag->{__top} eq 'form') {
+ if (defined($_ = $tag->{name})) {
+ $in_form = unescape_tag($_);
+ }
+ else {
+ $in_form = '';
+ }
+
+ $outhtml .= tag2html($tag);
+ }
+ elsif ($name ne $in_form) {
+ $outhtml .= $taghtml;
+ }
+ elsif ($tag->{__top} eq 'textarea') {
+ $in_textarea = 1;
+ $outhtml .= tag2html($tag);
+ }
+ elsif ($tag->{__top} eq '/textarea') {
+ $outhtml .= tag2html($tag);
+ undef $in_textarea;
+ }
+ elsif ($tag->{__top} eq 'input' or
+ $tag->{__top} eq 'select' or
+ $tag->{__top} eq 'textarea') {
+
+ my $name = $tag->{name};
+ if ($name and $keyhash{$name}) {
+ # disable this
+ $tag->{$is_xhtml ? 'disabled' : '__end'} = 'disabled';
+
+ # nameを消したいところだが、多分消した時の動作は實裝依存になる。
+ # 代はりにnameを別の名前に變換する。
+ $tag->{name} = sprintf 'DiSaBLeD_%s_DiSaBLeD', $tag->{name};
+ }
+
+ $outhtml .= tag2html($tag);
+ }
+ else {
+ $outhtml .= $taghtml;
+ }
+ }
+
+ $this->{current} = $outhtml;
+}
+
+1;
--- /dev/null
+@charset "UTF-8";
+
+* {
+ margin: 0;
+ padding: 0;
+}
+
+body {
+ background-color: #dddddd;
+}
+
+h1 {
+ font-size: 200%;
+ color: white;
+ background-color: #333388;
+
+ -moz-border-radius: 8px;
+
+ border-color: #7777bb;
+ border-width: 0 2px 2px 0;
+ border-style: solid;
+
+ padding: 5px;
+ margin: 10px;
+}
+
+#form, #list, #pasted {
+ margin: 0 10px 10px 10px;
+}
+table {
+ width: 100%;
+}
+th, td {
+ -moz-border-radius: 5px;
+}
+table th {
+ background-color: #333388;
+ color: white;
+ padding: 3px;
+}
+table td {
+ background-color: #7777bb;
+ color: white;
+ padding: 3px;
+}
+table input, table textarea, table select {
+ font-size: 110%;
+
+ background-color: #7f7fbf;
+ color: inherit;
+
+ border-color: #ddddff;
+ border-width: 1px;
+ border-style: dashed;
+
+ padding: 3px;
+}
+table input:hover, table textarea:hover, table select:hover {
+ background-color: #6f6faf;
+}
+table input[type="text"] {
+ width: 99%;
+}
+table input[type="submit"] {
+ font-size: 150%;
+ padding: 2px 5px;
+}
+table textarea {
+ font-size: 100%;
+
+ width: 99%;
+}
+
+.error {
+ margin: 5px 0px;
+ padding: 10px;
+ background-color: #bb7777;
+
+ -moz-border-radius: 6px;
+
+ color: white;
+ font-size: 120%;
+}
+
+a {
+ font-weight: bold;
+ color: white;
+ text-decoration: underline;
+ font-style: italic;
+}
+a:visited {
+ text-decoration: none;
+}
+
+#list, #pasted {
+ text-align: center;
+}
+#list table, #pasted table {
+ margin-top: 3px;
+}
+.pager {
+ display: inline;
+
+ background-color: #5f5faf;
+ color: white;
+
+ -moz-border-radius: 5px;
+
+ padding: 3px;
+}
+.pager a:visited {
+ text-decoration: underline;
+}
+
+#pasted td {
+ text-align: left;
+}
+#pasted th {
+ width: 10%;
+}
\ No newline at end of file
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE html
+ PUBLIC "-//W3C//DTD XHTML 1.1//EN"
+ "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
+<html xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <title><t-tag:status-code /> <t-tag:status-message /></title>
+ </head>
+ <body>
+ <h1><t-tag:status-message /></h1>
+ <p>
+ The requested URL <t-tag:requested-url /> is not valid for the NoPaste.<br />
+ </p>
+ </body>
+</html>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE html
+ PUBLIC "-//W3C//DTD XHTML 1.1//EN"
+ "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
+<html xml:lang="<t-tag:lang />" xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <title><t-tag:title /></title>
+ <link rel="stylesheet" type="text/css" href="/css/style.css" />
+ </head>
+ <body>
+ <h1><t-tag:title /></h1>
+
+ <t-block:writable>
+ <div id="form">
+ <t-block:error>
+ <p class="error"><t-tag:error /></p>
+ </t-block:error>
+
+ <form name="post" action="/post/<t-tag:channel-id />" method="post">
+ <table>
+ <tr>
+ <th><t-tag:l18n-name /></th>
+ <td>
+ <t-block:restricted>
+ <t-block:only-one>
+ <input type="hidden" name="nick" />
+ <t-tag:nick />
+ </t-block:only-one>
+ <t-block:multiple>
+ <select name="nick">
+ <t-block:entry>
+ <option><t-tag:nick /></option>
+ </t-block:entry>
+ </select>
+ </t-block:multiple>
+ </t-block:restricted>
+ <t-block:not-restricted>
+ <input type="text" name="nick" size="15" />
+ </t-block:not-restricted>
+ </td>
+ </tr>
+ <tr>
+ <th><t-tag:l18n-title /></th>
+ <td>
+ <input type="text" name="title" size="60" />
+ </td>
+ </tr>
+ <tr>
+ <th><t-tag:l18n-body /></th>
+ <td>
+ <textarea name="body" rows="15" cols="60"></textarea>
+ </td>
+ </tr>
+ <tr>
+ <th></th>
+ <td>
+ <input type="submit" value="<t-tag:l18n-paste />" />
+ </td>
+ </tr>
+ </table>
+ </form>
+ </div>
+ </t-block:writable>
+ <t-block:not-writable>
+ <div id="form">
+ <p class="error"><t-tag:error /></p>
+ </div>
+ </t-block:not-writable>
+
+ <t-block:readable>
+ <div id="list">
+
+ <p class="pager">
+ <t-block:prev>
+ <t-block:link>
+ <a href="?page=<t-tag:page />"><<</a>
+ </t-block:link>
+ <t-block:nolink>
+ <<
+ </t-block:nolink>
+ </t-block:prev>
+ <t-block:pages>
+ <t-block:page>
+ <t-block:link>
+ <a href="?page=<t-tag:page />"><t-tag:page /></a>
+ </t-block:link>
+ <t-block:nolink>
+ <t-tag:page />
+ </t-block:nolink>
+ </t-block:page>
+ </t-block:pages>
+ <t-block:next>
+ <t-block:link>
+ <a href="?page=<t-tag:page />">>></a>
+ </t-block:link>
+ <t-block:nolink>
+ >>
+ </t-block:nolink>
+ </t-block:next>
+ </p>
+
+ <table>
+ <tr>
+ <th><t-tag:l18n-title /></th>
+ <th><t-tag:l18n-name /></th>
+ <th><t-tag:l18n-timestamp /></th>
+ </tr>
+
+ <t-block:list-nodata>
+ <tr><td colspan="3"><t-tag:l18n-nodata /></td></tr>
+ </t-block:list-nodata>
+ <t-block:list-data>
+ <tr>
+ <td><a href="/pasted/<t-tag:id />"><t-tag:title /></a></td>
+ <td><t-tag:name /></td>
+ <td><t-tag:timestamp /></td>
+ </tr>
+ </t-block:list-data>
+ </table>
+ </div>
+ </t-block:readable>
+ <t-block:not-readable>
+ <div id="form">
+ <p class="error"><t-tag:error /></p>
+ </div>
+ </t-block:not-readable>
+ </body>
+</html>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE html
+ PUBLIC "-//W3C//DTD XHTML 1.1//EN"
+ "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
+<html xml:lang="<t-tag:lang />" xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <title><t-tag:title /></title>
+ <link rel="stylesheet" type="text/css" href="/css/style.css" />
+ </head>
+ <body>
+ <h1><t-tag:title /></h1>
+
+ <t-block:readable>
+ <div id="pasted">
+ <p class="pager">
+ <t-block:prev>
+ <a href="/pasted/<t-tag:id />" title="<t-tag:pasted-by />">
+ <t-tag:title /> <<
+ </a>
+ </t-block:prev>
+ <a href="/nopaste/<t-tag:channel-id />/">
+ <t-tag:l18n-index />
+ </a>
+ <t-block:next>
+ <a href="/pasted/<t-tag:id />" title="<t-tag:pasted-by />">
+ >> <t-tag:title />
+ </a>
+ </t-block:next>
+ </p>
+
+ <table>
+ <tr>
+ <th><t-tag:l18n-name /></th>
+ <td><t-tag:name /></td>
+ </tr>
+ <tr>
+ <th><t-tag:l18n-title /></th>
+ <td><t-tag:title /></td>
+ </tr>
+ <tr>
+ <th><t-tag:l18n-body /></th>
+ <td><pre><t-tag:body /></pre></td>
+ </tr>
+ </table>
+ </div>
+ </t-block:readable>
+ <t-block:not-readable>
+ <div id="form">
+ <p class="error"><t-tag:error /></p>
+ </div>
+ </t-block:not-readable>
+ </body>
+</html>
--- /dev/null
+# You can validate config files with this file by a tool named kwalify.
+# http://www.kuwata-lab.com/kwalify/
+
+# Usage:
+# kwalify -f nopaste-config-schema.yml <your-nopaste-config>
+
+type: map
+mapping:
+ "irc":
+ type: map
+ mapping:
+ "server" : {required: true}
+ "port" : {required: true, type: integer}
+ "nick" : {required: true}
+ "username": {required: true}
+ "ircname" : {required: true}
+ "httpd":
+ type: map
+ mapping:
+ "port": {required: true, type: integer}
+ "db":
+ type: map
+ mapping:
+ "file": {required: true}
+ "channels":
+ type: seq
+ sequence:
+ - type: map
+ mapping:
+ "name" : {required: true}
+ "id" : {required: true, pattern: "/^[a-zA-Z0-9_\-.]+$/"}
+ "charset" : {desc: default is "ISO-8859-1"}
+ "locale" : {desc: default is "en"}
+ "restriction":
+ type: map
+ mapping:
+ "read":
+ desc: default is "any"
+ enum: &permission [op, halfop, voice, member, any]
+ "write":
+ desc: default is "any"
+ enum: *permission
--- /dev/null
+-- posts
+CREATE TABLE post (
+ post_id INTEGER PRIMARY KEY, -- unique id of the post
+ channel_id VARCHAR(512) NOT NULL, -- id of the channel in ascii
+
+ posted_time INTEGER NOT NULL, -- timestamp in epoch
+ nick VARCHAR(512) NOT NULL, -- nick of the person who posted this
+ title BLOB NOT NULL, -- title of the post
+ body BLOB NOT NULL -- body of the post
+);
+
+-- Local Variables:
+-- sql-product: sqlite
+-- End:
\ No newline at end of file
--- /dev/null
+use File::Copy;
+
+print "Writing Makefile for po\n";
+copy "Makefile.in" => "Makefile";
--- /dev/null
+# Makefile for various po files.
+
+srcdir = .
+libdir = ../lib
+
+include PACKAGE
+
+#CATALOGS = $(addsuffix .po, LINGUAS)
+CATALOGS = $(LINGUAS)
+MO_FILES = $(addsuffix .mo, $(LINGUAS))
+
+MSGMERGE = msgmerge
+MSGFMT = msgfmt
+XGETTEXT = xgettext
+CATOBJEXT = .po
+
+default: help
+
+all: $(TEXTDOMAIN).pot update-po update-mo install
+
+help:
+ @echo "Available targets:"
+ @echo " pot - remake master catalog"
+ @echo " update-po - merge po files"
+ @echo " update-mo - regenerate mo files"
+ @echo " install - install mo files"
+ @echo " all - all of the above"
+
+POTFILES = $(srcdir)/POTFILES.in \
+ $(shell cat $(srcdir)/POTFILES.in)
+
+pot: $(TEXTDOMAIN).pot
+
+clean:
+ rm -f *~ *.bak *.mo
+
+# FIXME: The parameter --from-code is only needed if your sources contain
+# any 8 bit data (even in comments). UTF-8 is only a guess here, but it
+# will at least accept any 8 bit data.
+#
+# The parameter "--language=perl" is not strictly needed because the
+# source language of all our files will be auto-detected by xgettext
+# by their filename extension. You should even avoid this parameter
+# if you want to extract strings from multiple source languages.
+$(TEXTDOMAIN).pot: $(POTFILES)
+ $(XGETTEXT) --output=$(srcdir)/$(TEXTDOMAIN).pox --from-code=utf-8 \
+ --add-comments=TRANSLATORS: --files-from=$(srcdir)/POTFILES.in \
+ --copyright-holder="$(COPYRIGHT_HOLDER)" \
+ --msgid-bugs-address="$(MSGID_BUGS_ADDRESS)" \
+ --keyword --keyword='$$__' --keyword=__ --keyword=__x \
+ --keyword=__n:1,2 --keyword=__nx:1,2 --keyword=__xn:1,2 \
+ --keyword=N__ --language=perl && \
+ rm -f $@ && mv $(TEXTDOMAIN).pox $@
+
+install: $(MO_FILES)
+ cd $(srcdir); \
+ targetdir='$(libdir)/LocaleData'; \
+ languages='$(LINGUAS)'; \
+ for lang in $$languages; do \
+ mkdir -p "$$targetdir/$$lang/LC_MESSAGES" || exit 1; \
+ dest="$$targetdir/$$lang/LC_MESSAGES/$(TEXTDOMAIN).mo"; \
+ cat="$$lang.mo"; \
+ echo "installing $$cat as $$dest"; \
+ cp -f $$cat $$dest && chmod 644 $$dest || exit 1; \
+ done
+
+update-mo: $(MO_FILES)
+
+update-po:
+ $(MAKE) $(TEXTDOMAIN).pot
+ cd $(srcdir); \
+ catalogs='$(CATALOGS)'; \
+ for cat in $$catalogs; do \
+ cat=`basename $$cat`; \
+ lang=`echo $$cat | sed 's/\$(CATOBJEXT)$$//'`; \
+ mv $$lang.po $$lang.old.po; \
+ echo "$$lang:"; \
+ if $(MSGMERGE) $$lang.old.po $(TEXTDOMAIN).pot -o $$lang.po; then \
+ rm -f $$lang.old.po; \
+ else \
+ echo "msgmerge for $$cat failed!"; \
+ rm -f $$lang.po; \
+ mv $$lang.old.po $$lang.po; \
+ fi; \
+ done
+
+.SUFFIXES:
+.SUFFIXES: .po .mo
+
+.po.mo:
+ $(MSGFMT) --check --statistics --verbose -o $@ $<
+
--- /dev/null
+# -*- makefile -*-
+# Makefile snippet that holds all package-dependent information.
+
+# Add more languages here! Beware that this is a makefile snippet and
+# you have to adhere to make syntax.
+LINGUAS = \
+ ja \
+ $(NULL)
+
+# Textdomain for our package.
+TEXTDOMAIN = pci-nopaste
+
+# Initial copyright holder added to pot and po files.
+COPYRIGHT_HOLDER = phonohawk <phonohawk@ps.sakura.ne.jp>
+
+# Where to send msgid bugs?
+MSGID_BUGS_ADDRESS = phonohawk <phonohawk@ps.sakura.ne.jp>
--- /dev/null
+../bin/pci-nopaste
+../lib/POE/Component/IRC/Plugin/NoPaste.pm
+../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Index.pm
+../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Pasted.pm
\ No newline at end of file
--- /dev/null
+# SOME DESCRIPTIVE TITLE.
+# Copyright (C) YEAR phonohawk <phonohawk@ps.sakura.ne.jp>
+# This file is distributed under the same license as the PACKAGE package.
+# FIRST AUTHOR <EMAIL@ADDRESS>, YEAR.
+#
+msgid ""
+msgstr ""
+"Project-Id-Version: pci-nopaste #0\n"
+"Report-Msgid-Bugs-To: phonohawk <phonohawk@ps.sakura.ne.jp>\n"
+"POT-Creation-Date: 2012-11-06 12:58+0900\n"
+"PO-Revision-Date: 2005-09-24 17:57+0900\n"
+"Last-Translator: phonohawk <phonohawk@ps.sakura.ne.jp>\n"
+"Language-Team: Japanese <phonohawk@ps.sakura.ne.jp>\n"
+"Language: ja\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+
+#: ../bin/pci-nopaste:45
+#, perl-brace-format
+msgid "{process}: option --config=<config-file> is missing.\n"
+msgstr "{process}: オプション --config=<設定ファイル> が不足しています。\n"
+
+#: ../bin/pci-nopaste:79
+msgid "Shutdown time has arrived. Telling components to stop...\n"
+msgstr "終了の時が来ました。各部に停止指示を出しています…\n"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste.pm:82
+#, perl-brace-format
+msgid "connected to {server}:{port}."
+msgstr "{server}:{port} に接続しました。"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste.pm:116
+#, perl-brace-format
+msgid "{nick}: The NoPaste for {channel} is at {url}"
+msgstr "{nick}: {channel} の NoPaste は {url} に在ります。"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste.pm:195
+msgid "Sorry, but you can't paste to this channel;\n"
+msgstr "済みませんが、このチャンネルに貼り付ける事は出来ません。\n"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste.pm:201
+#: ../lib/POE/Component/IRC/Plugin/NoPaste.pm:225
+msgid "allowed only for those who have op in it."
+msgstr "op を持っている方のみに限られます。"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste.pm:204
+#: ../lib/POE/Component/IRC/Plugin/NoPaste.pm:228
+msgid "allowed only for those who have halfop in it."
+msgstr "halfop を持っている方のみに限られます。"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste.pm:207
+#: ../lib/POE/Component/IRC/Plugin/NoPaste.pm:231
+msgid "allowed only for those who have voice in it."
+msgstr "voice を持っている方のみに限られます。"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste.pm:210
+#: ../lib/POE/Component/IRC/Plugin/NoPaste.pm:234
+msgid "allowed only for those who are in it."
+msgstr "入室している方のみに限られます。"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste.pm:219
+msgid "Sorry, but you can't read posts pasted to this channel;\n"
+msgstr ""
+"済みませんが、このチャンネルへ貼り付けられた文章を読む事は出来ません。\n"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Index.pm:64
+#: ../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Index.pm:186
+#: ../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Pasted.pm:106
+msgid "Name"
+msgstr "名前"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Index.pm:88
+#: ../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Index.pm:185
+#: ../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Pasted.pm:108
+msgid "Title"
+msgstr "題名"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Index.pm:91
+#: ../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Pasted.pm:110
+msgid "Body"
+msgstr "本文"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Index.pm:93
+msgid "Paste"
+msgstr "貼り付ける"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Index.pm:178
+msgid "There are no entries currently."
+msgstr "項目は現在一つもありません。"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Index.pm:187
+msgid "Time Stamp"
+msgstr "貼り付け時刻"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Index.pm:213
+msgid "Please don't omit your name."
+msgstr "名前を省略しないで下さい。"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Index.pm:216
+#, perl-brace-format
+msgid "Please shorten your name up to {n} bytes."
+msgstr "名前は {n} バイト以内に縮めて下さい。"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Index.pm:219
+msgid "Please don't omit the title."
+msgstr "題名を省略しないで下さい。"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Index.pm:222
+#, perl-brace-format
+msgid "Please shorten the title up to {n} bytes."
+msgstr "題名は {n} バイト以内に縮めて下さい。"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Index.pm:225
+msgid "Please don't omit the body."
+msgstr "本文を省略しないで下さい。"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Index.pm:228
+#, perl-brace-format
+msgid "Please shorten the body up to {n} bytes."
+msgstr "本文は {n} バイト以内に縮めて下さい。"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Index.pm:251
+msgid "A duplicated entry is being pasted."
+msgstr "重複した貼付けを行おうとしています。"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Index.pm:270
+#, perl-brace-format
+msgid "{nick} pasted an entry: {title}"
+msgstr "{nick} が貼り付けました: {title}"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Pasted.pm:88
+#: ../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Pasted.pm:100
+#, perl-brace-format
+msgid "Pasted by {name}"
+msgstr "投稿者: {name}"
+
+#: ../lib/POE/Component/IRC/Plugin/NoPaste/Httpd/Pasted.pm:94
+msgid "Index"
+msgstr "目次"
--- /dev/null
+#!/bin/sh
+#
+# /etc/init.d/pci-nopaste
+#
+### BEGIN INIT INFO
+# Provides: pci-nopaste
+# Required-Start: $local_fs $remote_fs $network
+# Required-Stop: $local_fs $remote_fs $network
+# Default-Start: 3 5
+# Default-Stop: 0 1 2 6
+# Short-Description: An obsolete implementation of no-paste, based on POE::Component::IRC
+# Description: See http://git.cielonegro.org/gitweb.cgi?p=pci-nopaste.git;a=summary
+### END INIT INFO
+
+pidfile="@localstatedir@/pci-nopaste/pci-nopaste.pid"
+command="@DAEMON@ -f -p $pidfile @bindir@/pci-nopaste"
+command_args="--config=@sysconfdir@/pci-nopaste.conf"
+pci_nopaste_user="no-paste"
+
+success() {
+ RES_COL=60
+ echo -en "\\033[${RES_COL}G"
+ echo -n "["
+ echo -en "\\033[1;32m"
+ echo -n " OK "
+ echo -en "\\033[0;39m"
+ echo "]"
+}
+
+failure() {
+ RES_COL=60
+ echo -en "\\033[${RES_COL}G"
+ echo -n "["
+ echo -en "\\033[1;31m"
+ echo -n "FAILED"
+ echo -en "\\033[0;39m"
+ echo "]"
+}
+
+status() {
+ if [ -s "$pidfile" ]; then
+ read _pid < "$PIDFILE"
+
+ if [ -n "$_pid" -a -d "/proc/$_pid" ]; then
+ echo "pci-nopaste (pid $_pid) is running..."
+ return 0
+ else
+ echo "pci-nopaste is not running."
+ return 1
+ fi
+ else
+ echo "pci-nopaste is not running."
+ return 1
+ fi
+}
+
+start() {
+ if status >/dev/null 2>&1; then
+ echo "pci-nopaste is already running."
+ return 0
+ fi
+
+ echo -n "Starting pci-nopaste.."
+ /bin/su -s /bin/sh "$pci_nopaste_user" \
+ -c "$command $command_args"
+ RETVAL=$?
+
+ if [ $RETVAL -eq 0 ]; then
+ success
+ else
+ failure
+ fi
+
+ return $RETVAL
+}
+
+stop() {
+ if ! status >/dev/null 2>&1; then
+ echo "pci-nopaste not running? (check $pidfile)." 1>&2
+ exit 1
+ fi
+
+ echo -n "Stopping pci-nopaste: "
+ /bin/su -s /bin/sh "$pci_nopaste_user" \
+ -c "kill -TERM $_pid"
+ RETVAL=$?
+
+ if [ $? -eq 0 ]; then
+ success
+ else
+ failure
+ fi
+
+ return $RETVAL
+}
+
+restart() {
+ stop
+ start
+}
+
+RETVAL=0
+
+case "$1" in
+ start)
+ start
+ RETVAL=$?
+ ;;
+ stop)
+ stop
+ RETVAL=$?
+ ;;
+ restart|reload|force-reload)
+ restart
+ RETVAL=$?
+ ;;
+ status)
+ status
+ RETVAL=$?
+ ;;
+ *)
+ echo "Usage: $0 {start|stop|status|restart|reload|force-reload}"
+ RETVAL=1
+esac
+
+exit $RETVAL
--- /dev/null
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl POE-Component-IRC-Plugin-NoPaste.t'
+
+#########################
+
+# change 'tests => 1' to 'tests => last_test_to_print';
+
+use Test::More tests => 1;
+BEGIN { use_ok('POE::Component::IRC::Plugin::NoPaste') };
+
+#########################
+
+# Insert your test code below, the Test::More module is use()ed here so read
+# its man page ( perldoc Test::More ) for help writing this test script.
+
projects / pci-nopaste.git / commitdiff