[Bps-public-commit] Net-IMAP-Server branch, master, updated. 1.29-41-ge9c1fac
Alex Vandiver
alexmv at bestpractical.com
Tue May 24 16:33:20 EDT 2011
The branch, master has been updated
via e9c1facc8497a3b34331f3d056f711780c72bb71 (commit)
via 535d874de98632cdd6bcee53216672f6013c37bd (commit)
via e89ec152cbe4676ff1e4c5b341924d5187a1671e (commit)
via 0ad3f735c791843d24131f313327b5ce077ea89a (commit)
via ea2a57246ae7d1361653769aa015b4354649b775 (commit)
via 81e26b2f5966680a8ef2f55808dda7b149a50b93 (commit)
via aa3d3d0b8d459acd3b0654c0b88897eb7686de89 (commit)
via 4c0bf897c36fdb55fa95d5803c6d2934b1f4b993 (commit)
via 47965368b77c6cf1b04cc6bb1dd5af8120e9b64a (commit)
via e81de697ad968e08da560bcf597d152fd10779ca (commit)
via 8961a34023004988fd7c90850faf9afc008ad4fa (commit)
via 7ae056eabb917ad79adb3780d0123350292a1d61 (commit)
via dd1a99f6fbbe7d785371bcdf3653fae481ea84a2 (commit)
via 759e6954e6bb6f2c4a9fae37729c3b50f8650eff (commit)
via 85b7f7e7b244fc119b66d8b0a1405f6df441ea08 (commit)
via ba8657a54eacde14e44719d67aaac7ae8b23cb31 (commit)
via c4950665cf86b945b1a76c2e3d1dbe2ca14a4012 (commit)
via 5a494013829e70fa67b58523243e89971d454f54 (commit)
via 746dbde590fa9183702db9b472dc37fa85ac6b86 (commit)
via d4e6c860c20c7d973196d9ba9584060b31c6896d (commit)
via 145b4be4427596510a120e81e99d8d66c13aadbd (commit)
via 82ad8d89e4c3dad72f8ae71ecb40b77f2c294dc4 (commit)
via 73ab1d6ed39ec30216cfe1208d6a371023aac93a (commit)
via ade69ea543374ef230c37f3d17fe558e63be0056 (commit)
via 510a9e2266cd21390b53f9093ba13e143fe14794 (commit)
via 31c70be11864421b93a9eb85d0abc655595023ac (commit)
via 9b880d3712aafc4a8054653e5df98ee959f97fc5 (commit)
via ae69627dc6fb498ec271122b48f4b3e499e8d5ab (commit)
via c1d98e274528d68f72415af746680cbbdac31fc8 (commit)
via c9f1b6a22f9e1a6c2461f74a3755be89b70e799b (commit)
via fff0def402f51c63e6443b5337e768767f0773bc (commit)
via ca66d9cbd5912717d785755f46caa4a4ead28821 (commit)
via cb1fd34369dd6dded74e6cc80e662068237114c9 (commit)
via 5dee530e556ad6337ae99f45ca777a3550cba097 (commit)
via 78a37aa641cfa3116b90f809129d8a2839595baf (commit)
via cd612b133562f95917db5c45c0a2b6a007ca3f2b (commit)
from e15d8b6181c289d2b791a283be0fd9bec3a46a09 (commit)
Summary of changes:
.gitignore | 2 +
META.yml | 40 --
inc/Module/Install.pm | 441 -----------------
inc/Module/Install/Base.pm | 78 ---
inc/Module/Install/Can.pm | 81 ----
inc/Module/Install/Fetch.pm | 93 ----
inc/Module/Install/Makefile.pm | 405 ----------------
inc/Module/Install/Metadata.pm | 694 ---------------------------
inc/Module/Install/Win32.pm | 64 ---
inc/Module/Install/WriteAll.pm | 63 ---
lib/Net/IMAP/Server.pm | 2 +-
lib/Net/IMAP/Server/Command.pm | 29 ++
lib/Net/IMAP/Server/Command/Authenticate.pm | 33 +-
lib/Net/IMAP/Server/Command/Copy.pm | 3 +
lib/Net/IMAP/Server/Command/Create.pm | 12 +-
lib/Net/IMAP/Server/Command/Delete.pm | 1 +
lib/Net/IMAP/Server/Command/Fetch.pm | 3 +
lib/Net/IMAP/Server/Command/Login.pm | 11 +-
lib/Net/IMAP/Server/Command/Rename.pm | 3 +-
lib/Net/IMAP/Server/Command/Search.pm | 2 +-
lib/Net/IMAP/Server/Command/Select.pm | 12 +-
lib/Net/IMAP/Server/Command/Store.pm | 6 +
lib/Net/IMAP/Server/Connection.pm | 25 +-
lib/Net/IMAP/Server/DefaultAuth.pm | 1 +
lib/Net/IMAP/Server/DefaultModel.pm | 3 +-
t/01-connect.t | 36 ++
t/lib/Net/IMAP/Server/Test.pm | 204 ++++++++
t/lib/Net/IMAP/Server/Test/Auth.pm | 15 +
t/lib/Net/IMAP/Server/Test/Server.pm | 13 +
t/rfc-6.1.1-capability.t | 63 +++
t/rfc-6.1.2-noop.t | 29 ++
t/rfc-6.1.3-logout.t | 62 +++
t/rfc-6.2.1-starttls.t | 31 ++
t/rfc-6.2.2-authenticate.t | 65 +++
t/rfc-6.2.3-login.t | 35 ++
t/rfc-6.3.1-select.t | 70 +++
t/rfc-6.3.3-create.t | 76 +++
t/rfc-6.3.4-delete.t | 66 +++
t/rfc-6.3.5-rename.t | 68 +++
39 files changed, 938 insertions(+), 2002 deletions(-)
delete mode 100644 META.yml
delete mode 100644 inc/Module/Install.pm
delete mode 100644 inc/Module/Install/Base.pm
delete mode 100644 inc/Module/Install/Can.pm
delete mode 100644 inc/Module/Install/Fetch.pm
delete mode 100644 inc/Module/Install/Makefile.pm
delete mode 100644 inc/Module/Install/Metadata.pm
delete mode 100644 inc/Module/Install/Win32.pm
delete mode 100644 inc/Module/Install/WriteAll.pm
create mode 100644 t/01-connect.t
create mode 100644 t/lib/Net/IMAP/Server/Test.pm
create mode 100644 t/lib/Net/IMAP/Server/Test/Auth.pm
create mode 100644 t/lib/Net/IMAP/Server/Test/Server.pm
create mode 100644 t/rfc-6.1.1-capability.t
create mode 100644 t/rfc-6.1.2-noop.t
create mode 100644 t/rfc-6.1.3-logout.t
create mode 100644 t/rfc-6.2.1-starttls.t
create mode 100644 t/rfc-6.2.2-authenticate.t
create mode 100644 t/rfc-6.2.3-login.t
create mode 100644 t/rfc-6.3.1-select.t
create mode 100644 t/rfc-6.3.3-create.t
create mode 100644 t/rfc-6.3.4-delete.t
create mode 100644 t/rfc-6.3.5-rename.t
- Log -----------------------------------------------------------------
commit cd612b133562f95917db5c45c0a2b6a007ca3f2b
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Sat Jul 31 03:19:27 2010 -0400
Beginning of testing code
diff --git a/inc/Net/IMAP/Server/Test.pm b/inc/Net/IMAP/Server/Test.pm
new file mode 100644
index 0000000..2da5edf
--- /dev/null
+++ b/inc/Net/IMAP/Server/Test.pm
@@ -0,0 +1,186 @@
+package Net::IMAP::Server::Test;
+use base qw/Test::More/;
+
+use strict;
+use warnings;
+
+use IO::Socket::SSL;
+
+use constant PORT => 7000;
+use constant SSL_PORT => 7001;
+
+sub import_extra {
+ my $class = shift;
+ Test::More->export_to_level(2);
+}
+
+my $pid;
+sub start_server {
+ my $class = shift;
+ $class->stop_server;
+ unless ( $pid = fork ) {
+ require Net::IMAP::Server::Test::Server;
+ Net::IMAP::Server::Test::Server->new(
+ port => "localhost:".PORT,
+ ssl_port => "localhost:".SSL_PORT,
+ group => $(,
+ user => $<,
+ @_
+ )->run;
+ exit;
+ }
+ return $pid;
+}
+
+sub start_server_ok {
+ my $class = shift;
+ my $msg = @_ % 2 ? shift @_ : "Server started";
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ Test::More::ok($class->start_server(@_), $msg);
+}
+
+sub as {
+ my $class = shift;
+ my ($as) = @_;
+ $as =~ s/\W//g;
+ $as = "SOCKET_$as";
+ my $newclass = $class."::".$as;
+ return $newclass if exists $class->builder->{$as};
+ eval "{ package $newclass; our \@ISA = 'Net::IMAP::Server::Test'; sub socket_key { '$as' }; }";
+ $class->builder->{$as} = undef;
+ return $newclass;
+}
+
+sub socket_key { "SOCKET" };
+
+sub connect {
+ my $class = shift;
+ my %args = (
+ PeerAddr => 'localhost',
+ PeerPort => SSL_PORT,
+ Class => "IO::Socket::SSL",
+ @_
+ );
+ my $socketclass = delete $args{Class};
+ for (1..10) {
+ my $socket = $socketclass->new( %args );
+ return $class->builder->{$class->socket_key} = $socket if $socket;
+ sleep 1;
+ }
+ return;
+}
+
+sub get_socket {
+ my $class = shift;
+ return $class->builder->{$class->socket_key};
+}
+
+sub disconnect {
+ my $class = shift;
+ $class->get_socket->close;
+ $class->builder->{$class->socket_key} = undef;
+}
+
+sub connect_ok {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my $class = shift;
+ my $msg = @_ % 2 ? shift @_ : "Connected successfully";
+ my $socket = $class->connect(@_);
+ Test::More::ok($socket, $msg);
+ Test::More::like($socket->getline, qr/^\* OK\b/, "Got connection message");
+}
+
+sub start_tls {
+ my $class = shift;
+ IO::Socket::SSL->start_SSL($class->get_socket);
+}
+
+sub start_tls_ok {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my $class = shift;
+ my ($msg) = @_;
+ my $socket = $class->get_socket || return Test::More::fail("Not connected!");
+ $class->start_tls($socket);
+ Test::More::diag(IO::Socket::SSL::errstr())
+ unless $socket->isa("IO::Socket::SSL");
+ Test::More::ok(
+ $socket->isa("IO::Socket::SSL"),
+ $msg || "Negotiated TLS",
+ );
+}
+
+sub send_cmd {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my $class = shift;
+ my $cmd = shift;
+ $class->send_line("tag $cmd", @_);
+}
+
+sub send_line {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my $class = shift;
+ my ($cmd, $socket) = (@_, $class->get_socket);
+ my $response = "";
+ local $SIG{ALRM} = sub { die "Timeout" };
+ alarm(5);
+ eval {
+ $socket->print("$cmd\r\n");
+ while (my $line = $socket->getline) {
+ $response .= $line;
+ last if $line =~ /^(?:\+\s*$|tag\b)/;
+ }
+ };
+ Test::More::fail("$cmd: Timed out waiting for response")
+ if ($@ || "") =~ /Timeout/;
+ alarm(0);
+ return $response;
+}
+
+sub cmd_ok {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my $class = shift;
+ my ($cmd, $msg) = @_;
+ my $socket = $class->get_socket || return Test::More::fail("Not connected: $cmd");
+ my $response = $class->send_cmd($cmd, $socket);
+ Test::More::like($response, qr/^tag OK\b/m, $msg || "$cmd");
+ return $response;
+}
+
+sub cmd_like {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my $class = shift;
+ $class->_send_like("send_cmd", @_);
+}
+
+sub line_like {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my $class = shift;
+ $class->_send_like("send_line", @_);
+}
+
+sub _send_like {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my $class = shift;
+ my ($method, $cmd, @match) = @_;
+ my $socket = $class->get_socket || return Test::More::fail("Not connected: $cmd");
+ my $response = $class->$method($cmd, $socket);
+ my @got = split /\r\n/, $response;
+ Test::More::fail("Got wrong number of lines of response (expect @{[scalar @match]}, got @{[scalar @got]})")
+ unless @match == @got;
+ for my $i (0..$#match) {
+ my $match = ref $match[$i] ? $match[$i] : qr/^\Q$match[$i]\E\s*(?:\b|$)/;
+ Test::More::like($got[$i], $match, "Line @{[$i+1]} of $cmd response matched");
+ }
+ return wantarray ? @got : $response;
+}
+
+sub stop_server {
+ return unless $pid;
+ local $?;
+ kill 2, $pid;
+ 1 while wait > 0;
+}
+
+END { stop_server() }
+
+1;
diff --git a/inc/Net/IMAP/Server/Test/Auth.pm b/inc/Net/IMAP/Server/Test/Auth.pm
new file mode 100644
index 0000000..82f549a
--- /dev/null
+++ b/inc/Net/IMAP/Server/Test/Auth.pm
@@ -0,0 +1,8 @@
+package Net::IMAP::Server::Test::Auth;
+use base 'Net::IMAP::Server::DefaultAuth';
+
+use strict;
+use warnings;
+
+
+1;
diff --git a/inc/Net/IMAP/Server/Test/Server.pm b/inc/Net/IMAP/Server/Test/Server.pm
new file mode 100644
index 0000000..7139ee1
--- /dev/null
+++ b/inc/Net/IMAP/Server/Test/Server.pm
@@ -0,0 +1,13 @@
+package Net::IMAP::Server::Test::Server;
+use base 'Net::IMAP::Server';
+
+use strict;
+use warnings;
+
+sub write_to_log_hook {
+ my $self = shift;
+ my ($level, $msg) = @_;
+ Test::More::diag($msg) if $ENV{TEST_VERBOSE};
+}
+
+1;
diff --git a/t/01-connect.t b/t/01-connect.t
new file mode 100644
index 0000000..2e55032
--- /dev/null
+++ b/t/01-connect.t
@@ -0,0 +1,36 @@
+use lib 'inc';
+use strict;
+use warnings;
+
+use Net::IMAP::Server::Test;
+my $t = "Net::IMAP::Server::Test";
+
+$t->start_server_ok;
+
+# Check Non-SSL connection
+$t->connect_ok( "Non-SSL connection OK",
+ Class => "IO::Socket::INET",
+ PeerPort => $t->PORT,
+);
+
+# And STARTTLS
+$t->cmd_like("STARTTLS" => "tag OK");
+$t->start_tls_ok;
+$t->disconnect;
+
+# And the default SSL
+$t->connect_ok( "SSL connection OK" );
+$t->disconnect;
+
+# Check multiple concurrent connections
+$t->as("A")->connect_ok( "First client" );
+$t->as("A")->cmd_ok("NOOP", "First client can run commands" );
+$t->as("B")->connect_ok( "Second client" );
+$t->as("A")->cmd_ok("NOOP", "First client can still run commands" );
+$t->as("B")->cmd_ok("NOOP", "So can the second" );
+$t->as("B")->disconnect;
+$t->as("A")->cmd_ok("NOOP", "After the second disconnects, the first is still there" );
+$t->as("A")->disconnect;
+
+
+done_testing();
commit 78a37aa641cfa3116b90f809129d8a2839595baf
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Nov 10 14:26:23 2010 -0500
Test RFC specification of CAPABILITY
diff --git a/t/rfc-6.1.1-capability.t b/t/rfc-6.1.1-capability.t
new file mode 100644
index 0000000..eca5c1a
--- /dev/null
+++ b/t/rfc-6.1.1-capability.t
@@ -0,0 +1,66 @@
+use lib 'inc';
+use strict;
+use warnings;
+
+use Net::IMAP::Server::Test;
+my $t = "Net::IMAP::Server::Test";
+
+$t->start_server_ok;
+
+# SSL allows auth
+$t->connect_ok;
+my ($cap) = $t->cmd_like(
+ "CAPABILITY",
+ "* CAPABILITY",
+ "tag OK",
+);
+
+like($cap, qr/\bIMAP4rev1\b/, "Advertises IMAP4rev1");
+like($cap, qr/\bAUTH=PLAIN\b/, "Advertises AUTH=PLAIN over SSL");
+unlike($cap, qr/\bSTARTTLS\b/, "TLS is not advertized over SSL");
+unlike($cap, qr/\bLOGINDISABLED\b/, "Login is not DISABLED over SSL");
+
+# Try over simple TCP
+$t->connect_ok( "Non-SSL connection OK",
+ Class => "IO::Socket::INET",
+ PeerPort => $t->PORT,
+);
+($cap) = $t->cmd_like(
+ "CAPABILITY",
+ "* CAPABILITY",
+ "tag OK",
+);
+like($cap, qr/\bIMAP4rev1\b/, "Advertises IMAP4rev1");
+unlike($cap, qr/\bAUTH=PLAIN\b/, "Does not advertize AUTH=PLAIN over TCP");
+like($cap, qr/\bSTARTTLS\b/, "TLS is advertized over TCP");
+like($cap, qr/\bLOGINDISABLED\b/, "LOGINDISABLED over TCP");
+
+# Start up TLS and try again
+$t->cmd_like("STARTTLS" => "tag OK");
+$t->start_tls_ok;
+($cap) = $t->cmd_like(
+ "CAPABILITY",
+ "* CAPABILITY",
+ "tag OK",
+);
+like($cap, qr/\bIMAP4rev1\b/, "Advertises IMAP4rev1");
+like($cap, qr/\bAUTH=PLAIN\b/, "Advertises AUTH=PLAIN over TLS");
+unlike($cap, qr/\bSTARTTLS\b/, "TLS is not advertized over TLS");
+unlike($cap, qr/\bLOGINDISABLED\b/, "Login is not DISABLED over TLS");
+
+# See what changes once we're logged in
+$t->cmd_ok("LOGIN username password", "Logged in");
+($cap) = $t->cmd_like(
+ "CAPABILITY",
+ "* CAPABILITY",
+ "tag OK",
+);
+{
+ local $TODO = "Is this correct?";
+ like($cap, qr/\bIMAP4rev1\b/, "Advertises IMAP4rev1");
+ like($cap, qr/\bAUTH=PLAIN\b/, "Advertises AUTH=PLAIN over TLS");
+ unlike($cap, qr/\bSTARTTLS\b/, "TLS is not advertized over TLS");
+ unlike($cap, qr/\bLOGINDISABLED\b/, "Login is not DISABLED over TLS");
+}
+
+done_testing;
commit 5dee530e556ad6337ae99f45ca777a3550cba097
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Nov 10 14:26:29 2010 -0500
Test RFC specification of NOOP
diff --git a/t/rfc-6.1.2-noop.t b/t/rfc-6.1.2-noop.t
new file mode 100644
index 0000000..708e95f
--- /dev/null
+++ b/t/rfc-6.1.2-noop.t
@@ -0,0 +1,29 @@
+use lib 'inc';
+use strict;
+use warnings;
+
+use Net::IMAP::Server::Test;
+my $t = "Net::IMAP::Server::Test";
+
+$t->start_server_ok;
+
+$t->connect_ok;
+$t->cmd_like(
+ "NOOP",
+ "tag OK",
+);
+
+$t->cmd_ok("LOGIN username password");
+$t->cmd_like(
+ "NOOP",
+ "tag OK",
+);
+
+$t->cmd_ok("SELECT INBOX");
+$t->cmd_like(
+ "NOOP",
+ "tag OK",
+);
+
+done_testing;
+
commit cb1fd34369dd6dded74e6cc80e662068237114c9
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Nov 10 14:27:49 2010 -0500
Test RFC specification of LOGOUT
diff --git a/t/rfc-6.1.3-logout.t b/t/rfc-6.1.3-logout.t
new file mode 100644
index 0000000..a4bf6fe
--- /dev/null
+++ b/t/rfc-6.1.3-logout.t
@@ -0,0 +1,62 @@
+use lib 'inc';
+use strict;
+use warnings;
+
+use Net::IMAP::Server::Test;
+my $t = "Net::IMAP::Server::Test";
+
+$t->start_server_ok;
+
+# Non-SSL
+$t->connect_ok( "Non-SSL connection OK",
+ Class => "IO::Socket::INET",
+ PeerPort => $t->PORT,
+);
+ok($t->get_socket->connected, "Is connected");
+$t->cmd_like(
+ "LOGOUT",
+ "* BYE",
+ "tag OK",
+);
+{
+ local $TODO = "It doesn't realize it has been disconnected";
+ ok(!$t->get_socket->connected, "Is still connected");
+ $t->get_socket->print("\n");
+}
+ok(!$t->get_socket->connected, "Is still connected");
+
+# SSL connection
+$t->connect_ok;
+ok($t->get_socket->connected, "Is connected");
+$t->cmd_like(
+ "LOGOUT",
+ "* BYE",
+ "tag OK",
+);
+{
+ local $TODO = "It doesn't realize it has been disconnected";
+ ok(!$t->get_socket->connected, "Is still connected");
+ $t->get_socket->print("\n");
+}
+ok(!$t->get_socket->connected, "Is still connected");
+
+# Logged in
+$t->connect_ok;
+$t->cmd_ok("LOGIN username password");
+$t->cmd_like(
+ "LOGOUT",
+ "* BYE",
+ "tag OK",
+);
+
+# And selected
+$t->connect_ok;
+$t->cmd_ok("LOGIN username password");
+$t->cmd_ok("SELECT INBOX");
+$t->cmd_like(
+ "LOGOUT",
+ "* BYE",
+ "tag OK",
+);
+
+done_testing;
commit ca66d9cbd5912717d785755f46caa4a4ead28821
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Nov 10 14:28:10 2010 -0500
Test RFC specification of STARTTLS
diff --git a/t/rfc-6.2.1-starttls.t b/t/rfc-6.2.1-starttls.t
new file mode 100644
index 0000000..ddafdd7
--- /dev/null
+++ b/t/rfc-6.2.1-starttls.t
@@ -0,0 +1,31 @@
+use lib 'inc';
+use strict;
+use warnings;
+
+use Net::IMAP::Server::Test;
+my $t = "Net::IMAP::Server::Test";
+
+$t->start_server_ok;
+
+# Invalid over SSL
+$t->connect_ok;
+$t->cmd_like("STARTTLS" => "tag NO STARTTLS is disabled");
+$t->cmd_ok("LOGOUT");
+
+# Connect over TCP
+$t->connect_ok( "Non-SSL connection OK",
+ Class => "IO::Socket::INET",
+ PeerPort => $t->PORT,
+);
+
+$t->cmd_like("STARTTLS" => "tag OK");
+$t->start_tls_ok;
+
+# Check that you can't STARTTLS twice
+$t->cmd_like("STARTTLS" => "tag NO STARTTLS is disabled");
+
+# Check that it fails after auth
+$t->cmd_ok("LOGIN username password");
+$t->cmd_like("STARTTLS" => "tag BAD Already logged in");
+
+done_testing;
commit fff0def402f51c63e6443b5337e768767f0773bc
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Nov 10 14:28:59 2010 -0500
Add authentication code for testing
diff --git a/inc/Net/IMAP/Server/Test.pm b/inc/Net/IMAP/Server/Test.pm
index 2da5edf..dcc3e3d 100644
--- a/inc/Net/IMAP/Server/Test.pm
+++ b/inc/Net/IMAP/Server/Test.pm
@@ -21,6 +21,7 @@ sub start_server {
unless ( $pid = fork ) {
require Net::IMAP::Server::Test::Server;
Net::IMAP::Server::Test::Server->new(
+ auth_class => "Net::IMAP::Server::Test::Auth",
port => "localhost:".PORT,
ssl_port => "localhost:".SSL_PORT,
group => $(,
diff --git a/inc/Net/IMAP/Server/Test/Auth.pm b/inc/Net/IMAP/Server/Test/Auth.pm
index 82f549a..7187c4d 100644
--- a/inc/Net/IMAP/Server/Test/Auth.pm
+++ b/inc/Net/IMAP/Server/Test/Auth.pm
@@ -4,5 +4,12 @@ use base 'Net::IMAP::Server::DefaultAuth';
use strict;
use warnings;
+sub auth_plain {
+ my $self = shift;
+ my ($user, $pass) = (@_);
+ return unless $pass eq "password";
+ $self->user($user);
+ return 1;
+}
1;
commit c9f1b6a22f9e1a6c2461f74a3755be89b70e799b
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Nov 10 14:29:37 2010 -0500
Enforce that AUTHORIZE have all three parts (authz, user, and pass)
diff --git a/lib/Net/IMAP/Server/DefaultAuth.pm b/lib/Net/IMAP/Server/DefaultAuth.pm
index 3ba2b3c..49cda22 100644
--- a/lib/Net/IMAP/Server/DefaultAuth.pm
+++ b/lib/Net/IMAP/Server/DefaultAuth.pm
@@ -87,6 +87,7 @@ sub sasl_plain {
return \"" unless $line;
my ( $authz, $user, $pass ) = split /\x{0}/, $line, 3;
+ return 0 unless defined $authz and defined $user and defined $pass;
return $self->auth_plain( $user, $pass );
};
}
commit c1d98e274528d68f72415af746680cbbdac31fc8
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Nov 10 14:30:03 2010 -0500
Test RFC specification of AUTHENTICATE (only testing PLAIN)
diff --git a/t/rfc-6.2.2-authenticate.t b/t/rfc-6.2.2-authenticate.t
new file mode 100644
index 0000000..87374f5
--- /dev/null
+++ b/t/rfc-6.2.2-authenticate.t
@@ -0,0 +1,57 @@
+use lib 'inc';
+use strict;
+use warnings;
+
+use Net::IMAP::Server::Test;
+my $t = "Net::IMAP::Server::Test";
+
+$t->start_server_ok;
+
+# Connect over SSL
+$t->connect_ok;
+
+# We support PLAIN auth by default
+my ($cap) = $t->cmd_like(
+ "CAPABILITY",
+ "* CAPABILITY",
+ "tag OK",
+);
+
+like($cap, qr/\bAUTH=PLAIN\b/, "Advertises AUTH=PLAIN");
+
+# Try a bogus auth type
+$t->cmd_like("AUTHENTICATE BOGUS aaa", "tag NO");
+
+# Fail the auth by not base64-encoding
+$t->cmd_like("AUTHENTICATE PLAIN bogus", "tag BAD");
+
+# Omit the password
+use MIME::Base64;
+my $base64 = encode_base64("authz\0username"); chomp $base64;
+$t->cmd_like("AUTHENTICATE PLAIN $base64", "tag BAD");
+
+# Wrong password
+$base64 = encode_base64("authz\0username\0wrong"); chomp $base64;
+$t->cmd_like("AUTHENTICATE PLAIN $base64", "tag BAD");
+
+# Correct login
+$base64 = encode_base64("authz\0username\0password"); chomp $base64;
+$t->cmd_like("AUTHENTICATE PLAIN $base64", "tag OK");
+
+# Can't login again
+$t->cmd_like("AUTHENTICATE PLAIN $base64", "tag BAD");
+$t->cmd_ok("LOGOUT");
+
+# Do the auth over two lines
+$t->connect_ok;
+$t->cmd_like("AUTHENTICATE PLAIN", "+");
+$t->line_like($base64, "tag OK");
+$t->cmd_ok("LOGOUT");
+
+# Test cancelling auth
+$t->connect_ok;
+$t->cmd_like("AUTHENTICATE PLAIN", "+");
+$t->line_like("*", "tag BAD");
+
+
+done_testing;
commit ae69627dc6fb498ec271122b48f4b3e499e8d5ab
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Nov 10 16:06:28 2010 -0500
Improve and fix the error message with unsupported AUTH types
diff --git a/lib/Net/IMAP/Server/Command/Authenticate.pm b/lib/Net/IMAP/Server/Command/Authenticate.pm
index d17a806..304639b 100644
--- a/lib/Net/IMAP/Server/Command/Authenticate.pm
+++ b/lib/Net/IMAP/Server/Command/Authenticate.pm
@@ -18,7 +18,7 @@ sub validate {
return $self->bad_command("Not enough options") if @options < 1;
return $self->bad_command("Too many options") if @options > 2;
- return $self->no_command("Login is disabled")
+ return $self->no_command("Authentication type not supported")
unless $self->connection->capability =~ /\bAUTH=$options[0]\b/i;
return 1;
@@ -38,7 +38,7 @@ sub run {
$self->connection->pending(sub {$self->continue(@_)});
$self->continue( $arg || "");
} else {
- $self->bad_command("Invalid login");
+ $self->no_command("Authentication type not supported");
}
}
commit 9b880d3712aafc4a8054653e5df98ee959f97fc5
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Nov 10 16:21:18 2010 -0500
An invalid login is NO, not BAD, according to spec
diff --git a/lib/Net/IMAP/Server/Command/Authenticate.pm b/lib/Net/IMAP/Server/Command/Authenticate.pm
index 304639b..2b88291 100644
--- a/lib/Net/IMAP/Server/Command/Authenticate.pm
+++ b/lib/Net/IMAP/Server/Command/Authenticate.pm
@@ -66,7 +66,7 @@ sub continue {
$self->ok_completed();
} else {
$self->connection->pending(undef);
- $self->bad_command("Invalid login");
+ $self->no_command("Invalid login");
}
}
diff --git a/lib/Net/IMAP/Server/Command/Login.pm b/lib/Net/IMAP/Server/Command/Login.pm
index 3d12787..2e73ff5 100644
--- a/lib/Net/IMAP/Server/Command/Login.pm
+++ b/lib/Net/IMAP/Server/Command/Login.pm
@@ -32,7 +32,7 @@ sub run {
$self->connection->auth($auth);
$self->ok_completed();
} else {
- $self->bad_command("Invalid login");
+ $self->no_command("Invalid login");
}
}
diff --git a/t/rfc-6.2.2-authenticate.t b/t/rfc-6.2.2-authenticate.t
index 87374f5..e4d0dcb 100644
--- a/t/rfc-6.2.2-authenticate.t
+++ b/t/rfc-6.2.2-authenticate.t
@@ -32,7 +32,7 @@ $t->cmd_like("AUTHENTICATE PLAIN $base64", "tag BAD");
# Wrong password
$base64 = encode_base64("authz\0username\0wrong"); chomp $base64;
-$t->cmd_like("AUTHENTICATE PLAIN $base64", "tag BAD");
+$t->cmd_like("AUTHENTICATE PLAIN $base64", "tag NO");
# Correct login
$base64 = encode_base64("authz\0username\0password"); chomp $base64;
commit 31c70be11864421b93a9eb85d0abc655595023ac
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Nov 10 16:47:38 2010 -0500
Refector to default to clearing pending() each time ->continue is called
diff --git a/lib/Net/IMAP/Server/Command/Authenticate.pm b/lib/Net/IMAP/Server/Command/Authenticate.pm
index 2b88291..89f3f48 100644
--- a/lib/Net/IMAP/Server/Command/Authenticate.pm
+++ b/lib/Net/IMAP/Server/Command/Authenticate.pm
@@ -46,11 +46,10 @@ sub continue {
my $self = shift;
my $line = shift;
- if ( not defined $line or $line =~ /^\*[\r\n]+$/ ) {
- $self->connection->pending(undef);
- $self->bad_command("Login cancelled");
- return;
- }
+ $self->connection->pending(undef);
+
+ return $self->bad_command("Login cancelled")
+ if not defined $line or $line =~ /^\*[\r\n]+$/;
{
local $^W; # Avoid "Premature end of base64 data", etc..
@@ -59,13 +58,12 @@ sub continue {
my $response = $self->sasl->($line);
if ( ref $response ) {
+ $self->connection->pending(sub{$self->continue(@_)});
$self->out( "+ " . encode_base64($$response) );
} elsif ($response) {
- $self->connection->pending(undef);
$self->connection->auth( $self->pending_auth );
$self->ok_completed();
} else {
- $self->connection->pending(undef);
$self->no_command("Invalid login");
}
}
commit 510a9e2266cd21390b53f9093ba13e143fe14794
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Nov 10 16:48:22 2010 -0500
Trap and report base64 errors
diff --git a/lib/Net/IMAP/Server/Command/Authenticate.pm b/lib/Net/IMAP/Server/Command/Authenticate.pm
index 89f3f48..f23cd5c 100644
--- a/lib/Net/IMAP/Server/Command/Authenticate.pm
+++ b/lib/Net/IMAP/Server/Command/Authenticate.pm
@@ -51,10 +51,14 @@ sub continue {
return $self->bad_command("Login cancelled")
if not defined $line or $line =~ /^\*[\r\n]+$/;
+ my $fail = 0;
{
- local $^W; # Avoid "Premature end of base64 data", etc..
+ # Trap and fail on "Premature end of base64 data", etc..
+ local $^W = 1;
+ local $SIG{__WARN__} = sub {$_[0] =~ /base64/i and $fail++};
$line = decode_base64($line);
}
+ return $self->bad_command("Invalid base64") if $fail;
my $response = $self->sasl->($line);
if ( ref $response ) {
commit ade69ea543374ef230c37f3d17fe558e63be0056
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Nov 10 16:49:43 2010 -0500
Split protocol failure out from invalid credentials
Returning -1 from a SASL fuction now returns BAD
diff --git a/lib/Net/IMAP/Server/Command/Authenticate.pm b/lib/Net/IMAP/Server/Command/Authenticate.pm
index f23cd5c..adeaef6 100644
--- a/lib/Net/IMAP/Server/Command/Authenticate.pm
+++ b/lib/Net/IMAP/Server/Command/Authenticate.pm
@@ -64,11 +64,13 @@ sub continue {
if ( ref $response ) {
$self->connection->pending(sub{$self->continue(@_)});
$self->out( "+ " . encode_base64($$response) );
- } elsif ($response) {
+ } elsif (not $response) {
+ $self->no_command("Invalid login");
+ } elsif ($response < 0) {
+ $self->bad_command("Protocol failure");
+ } else {
$self->connection->auth( $self->pending_auth );
$self->ok_completed();
- } else {
- $self->no_command("Invalid login");
}
}
diff --git a/lib/Net/IMAP/Server/Command/Login.pm b/lib/Net/IMAP/Server/Command/Login.pm
index 2e73ff5..225bfc6 100644
--- a/lib/Net/IMAP/Server/Command/Login.pm
+++ b/lib/Net/IMAP/Server/Command/Login.pm
@@ -26,9 +26,9 @@ sub run {
$self->server->auth_class->require || $self->log( 1, $@ );
my $auth = $self->server->auth_class->new;
- if ( $auth->provides_plain
- and $auth->auth_plain( $self->parsed_options ) )
- {
+ if (not $auth->provides_plain) {
+ $self->bad_command("Protocol failure");
+ } elsif ( $auth->auth_plain( $self->parsed_options ) ) {
$self->connection->auth($auth);
$self->ok_completed();
} else {
diff --git a/lib/Net/IMAP/Server/DefaultAuth.pm b/lib/Net/IMAP/Server/DefaultAuth.pm
index 49cda22..dcf3402 100644
--- a/lib/Net/IMAP/Server/DefaultAuth.pm
+++ b/lib/Net/IMAP/Server/DefaultAuth.pm
@@ -87,7 +87,7 @@ sub sasl_plain {
return \"" unless $line;
my ( $authz, $user, $pass ) = split /\x{0}/, $line, 3;
- return 0 unless defined $authz and defined $user and defined $pass;
+ return -1 unless defined $authz and defined $user and defined $pass;
return $self->auth_plain( $user, $pass );
};
}
commit 73ab1d6ed39ec30216cfe1208d6a371023aac93a
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Nov 10 16:53:41 2010 -0500
Look for explicit types of messages, not just BAD and NO
diff --git a/t/rfc-6.2.2-authenticate.t b/t/rfc-6.2.2-authenticate.t
index e4d0dcb..4586a1a 100644
--- a/t/rfc-6.2.2-authenticate.t
+++ b/t/rfc-6.2.2-authenticate.t
@@ -18,28 +18,29 @@ my ($cap) = $t->cmd_like(
);
like($cap, qr/\bAUTH=PLAIN\b/, "Advertises AUTH=PLAIN");
+unlike($cap, qr/\bAUTH=BOGUS\b/, "Doesn't advertise AUTH=BOGUS");
# Try a bogus auth type
-$t->cmd_like("AUTHENTICATE BOGUS aaa", "tag NO");
+$t->cmd_like("AUTHENTICATE BOGUS aaa", "tag NO Authentication type not supported");
# Fail the auth by not base64-encoding
-$t->cmd_like("AUTHENTICATE PLAIN bogus", "tag BAD");
+$t->cmd_like("AUTHENTICATE PLAIN bogus", "tag BAD Invalid base64");
# Omit the password
use MIME::Base64;
my $base64 = encode_base64("authz\0username"); chomp $base64;
-$t->cmd_like("AUTHENTICATE PLAIN $base64", "tag BAD");
+$t->cmd_like("AUTHENTICATE PLAIN $base64", "tag BAD Protocol failure");
# Wrong password
$base64 = encode_base64("authz\0username\0wrong"); chomp $base64;
-$t->cmd_like("AUTHENTICATE PLAIN $base64", "tag NO");
+$t->cmd_like("AUTHENTICATE PLAIN $base64", "tag NO Invalid login");
# Correct login
$base64 = encode_base64("authz\0username\0password"); chomp $base64;
$t->cmd_like("AUTHENTICATE PLAIN $base64", "tag OK");
# Can't login again
-$t->cmd_like("AUTHENTICATE PLAIN $base64", "tag BAD");
+$t->cmd_like("AUTHENTICATE PLAIN $base64", "tag BAD Already logged in");
$t->cmd_ok("LOGOUT");
# Do the auth over two lines
@@ -51,7 +52,7 @@ $t->cmd_ok("LOGOUT");
# Test cancelling auth
$t->connect_ok;
$t->cmd_like("AUTHENTICATE PLAIN", "+");
-$t->line_like("*", "tag BAD");
+$t->line_like("*", "tag BAD Login cancelled");
done_testing;
commit 82ad8d89e4c3dad72f8ae71ecb40b77f2c294dc4
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Nov 10 16:56:23 2010 -0500
Display a warning when plaintext auth goes over the wire unencrypted
diff --git a/lib/Net/IMAP/Server/Command/Authenticate.pm b/lib/Net/IMAP/Server/Command/Authenticate.pm
index adeaef6..53a3537 100644
--- a/lib/Net/IMAP/Server/Command/Authenticate.pm
+++ b/lib/Net/IMAP/Server/Command/Authenticate.pm
@@ -18,6 +18,9 @@ sub validate {
return $self->bad_command("Not enough options") if @options < 1;
return $self->bad_command("Too many options") if @options > 2;
+ $self->untagged_response("BAD [ALERT] Plaintext authentication not over SSL is insecure -- your password was just exposed.")
+ if $options[0] eq "PLAIN" and not $self->connection->is_encrypted;
+
return $self->no_command("Authentication type not supported")
unless $self->connection->capability =~ /\bAUTH=$options[0]\b/i;
diff --git a/lib/Net/IMAP/Server/Command/Login.pm b/lib/Net/IMAP/Server/Command/Login.pm
index 225bfc6..0278bc0 100644
--- a/lib/Net/IMAP/Server/Command/Login.pm
+++ b/lib/Net/IMAP/Server/Command/Login.pm
@@ -15,6 +15,9 @@ sub validate {
return $self->bad_command("Not enough options") if @options < 2;
return $self->bad_command("Too many options") if @options > 2;
+ $self->untagged_response("BAD [ALERT] Plaintext authentication not over SSL is insecure -- your password was just exposed.")
+ unless $self->connection->is_encrypted;
+
return $self->no_command("Login is disabled")
if $self->connection->capability =~ /\bLOGINDISABLED\b/;
diff --git a/t/rfc-6.2.2-authenticate.t b/t/rfc-6.2.2-authenticate.t
index 4586a1a..0933b4a 100644
--- a/t/rfc-6.2.2-authenticate.t
+++ b/t/rfc-6.2.2-authenticate.t
@@ -53,6 +53,13 @@ $t->cmd_ok("LOGOUT");
$t->connect_ok;
$t->cmd_like("AUTHENTICATE PLAIN", "+");
$t->line_like("*", "tag BAD Login cancelled");
+$t->cmd_ok("LOGOUT");
+# AUTHENTICATE PLAIN is disabled over non-SSL
+$t->connect_ok( "Non-SSL connection OK",
+ Class => "IO::Socket::INET",
+ PeerPort => $t->PORT,
+);
+$t->cmd_like("AUTHENTICATE PLAIN $base64", "* BAD [ALERT]", "tag NO");
done_testing;
commit 145b4be4427596510a120e81e99d8d66c13aadbd
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Nov 10 16:57:09 2010 -0500
Test RFC specification of LOGIN
diff --git a/t/rfc-6.2.3-login.t b/t/rfc-6.2.3-login.t
new file mode 100644
index 0000000..89e0505
--- /dev/null
+++ b/t/rfc-6.2.3-login.t
@@ -0,0 +1,35 @@
+use lib 'inc';
+use strict;
+use warnings;
+
+use Net::IMAP::Server::Test;
+my $t = "Net::IMAP::Server::Test";
+
+$t->start_server_ok;
+
+# Connect over SSL
+$t->connect_ok;
+
+# Try a wrong password
+$t->cmd_like("LOGIN username wrong", "tag NO");
+
+# The right password works
+$t->cmd_like("LOGIN username password", "tag OK");
+
+# You can't auth if you already are
+$t->cmd_like("LOGIN username password", "tag BAD");
+$t->cmd_ok("LOGOUT");
+
+# You can't auth over non-SSL
+$t->connect_ok( "Non-SSL connection OK",
+ Class => "IO::Socket::INET",
+ PeerPort => $t->PORT,
+);
+$t->cmd_like("LOGIN username password", "* BAD [ALERT]", "tag NO");
+
+# But once you STARTTLS, you're fine
+$t->cmd_like("STARTTLS" => "tag OK");
+$t->start_tls_ok;
+$t->cmd_like("LOGIN username password", "tag OK");
+
+done_testing;
commit d4e6c860c20c7d973196d9ba9584060b31c6896d
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Nov 10 21:03:55 2010 -0500
Be a bit pickier about message sequence sets
diff --git a/lib/Net/IMAP/Server/Command/Copy.pm b/lib/Net/IMAP/Server/Command/Copy.pm
index f4a4d47..6af98e3 100644
--- a/lib/Net/IMAP/Server/Command/Copy.pm
+++ b/lib/Net/IMAP/Server/Command/Copy.pm
@@ -18,6 +18,9 @@ sub validate {
return $self->bad_command("Not enough options") if @options < 2;
return $self->bad_command("Too many options") if @options > 2;
+ return $self->bad_command("Invalid message set")
+ unless $options[0] =~ $self->connection->SEQUENCE_STRING;
+
my $mailbox = $self->connection->model->lookup( $options[1] );
return $self->no_command("[TRYCREATE] Mailbox does not exist") unless $mailbox;
return $self->bad_command("Mailbox is read-only") if $mailbox->read_only;
diff --git a/lib/Net/IMAP/Server/Command/Fetch.pm b/lib/Net/IMAP/Server/Command/Fetch.pm
index da1ea21..04f3504 100644
--- a/lib/Net/IMAP/Server/Command/Fetch.pm
+++ b/lib/Net/IMAP/Server/Command/Fetch.pm
@@ -18,6 +18,9 @@ sub validate {
return $self->bad_command("Not enough options") if @options < 2;
return $self->bad_command("Too many options") if @options > 2;
+ return $self->bad_command("Invalid message set")
+ unless $options[0] =~ $self->connection->SEQUENCE_STRING;
+
return 1;
}
diff --git a/lib/Net/IMAP/Server/Command/Search.pm b/lib/Net/IMAP/Server/Command/Search.pm
index e60aeab..65d42af 100644
--- a/lib/Net/IMAP/Server/Command/Search.pm
+++ b/lib/Net/IMAP/Server/Command/Search.pm
@@ -166,7 +166,7 @@ sub filter {
push @{$filters}, sub {not $_[0]->has_flag($keyword)};
} elsif ($token eq "UNSEEN") {
push @{$filters}, sub {not $_[0]->has_flag('\Seen')};
- } elsif ($token =~ /^(\*|\d+)(:(\*|\d+))?(,(\*|\d+)(:(\*|\d+))?)*$/) {
+ } elsif ($token =~ $self->connection->SEQUENCE_STRING) {
my %uids;
$uids{$_->uid}++ for $self->connection->get_messages($token);
push @{$filters}, sub {$uids{$_[0]->uid}};
diff --git a/lib/Net/IMAP/Server/Command/Store.pm b/lib/Net/IMAP/Server/Command/Store.pm
index 2cbc44d..3c0dae4 100644
--- a/lib/Net/IMAP/Server/Command/Store.pm
+++ b/lib/Net/IMAP/Server/Command/Store.pm
@@ -20,6 +20,12 @@ sub validate {
return $self->bad_command("Not enough options") if @options < 3;
return $self->bad_command("Too many options") if @options > 3;
+ return $self->bad_command("Invalid message set")
+ unless $options[0] =~ $self->connection->SEQUENCE_STRING;
+
+ return $self->bad_command("Invalid FLAGS option")
+ unless $options[1] =~ /^[+-]?FLAGS(\.SILENT)?$/;
+
return 1;
}
diff --git a/lib/Net/IMAP/Server/Connection.pm b/lib/Net/IMAP/Server/Connection.pm
index 30b473d..6d5a7bb 100644
--- a/lib/Net/IMAP/Server/Connection.pm
+++ b/lib/Net/IMAP/Server/Connection.pm
@@ -523,6 +523,8 @@ connection-dependent sequence numbers.
=cut
+use constant SEQUENCE_TOKEN => qr/(?:\d+:\d+|\d+:\*|\*:\d+|\d+|\*)/;
+use constant SEQUENCE_STRING => qr/^@{[SEQUENCE_TOKEN]}(,@{[SEQUENCE_TOKEN]})*$/;
sub get_messages {
my $self = shift;
my $str = shift;
commit 746dbde590fa9183702db9b472dc37fa85ac6b86
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Nov 10 21:04:50 2010 -0500
Tighten up CAPABILITY logic with respect to presenting AUTH=PLAIN and STARTTLS
diff --git a/lib/Net/IMAP/Server/Connection.pm b/lib/Net/IMAP/Server/Connection.pm
index 6d5a7bb..141c25d 100644
--- a/lib/Net/IMAP/Server/Connection.pm
+++ b/lib/Net/IMAP/Server/Connection.pm
@@ -576,16 +576,25 @@ sub capability {
my $self = shift;
my $base = $self->server->capability;
- if ( $self->is_encrypted ) {
+ my @words = split " ", $base;
+
+ # Skip STARTTLS if we're encrpyted
+ @words = grep {$_ ne "STARTTLS"} @words
+ if $self->is_encrypted;
+
+ # If we're auth'd, no need to list any AUTH or LOGINDISABLED
+ unless ($self->auth) {
my $auth = $self->auth || $self->server->auth_class->new;
- $base = join( " ",
- grep { $_ ne "STARTTLS" } split( ' ', $base ),
- map {"AUTH=$_"} $auth->sasl_provides );
- } else {
- $base = "$base LOGINDISABLED";
+ my @auth = $auth->sasl_provides;
+ unless ($self->is_encrypted) {
+ # Lack of encrpytion makes us turn off all plaintext auth
+ push @words, "LOGINDISABLED";
+ @auth = grep {$_ ne "PLAIN"} @auth;
+ }
+ push @words, map {"AUTH=$_"} @auth;
}
- return $base;
+ return join(" ", @words);
}
=head2 log SEVERITY, MESSAGE
diff --git a/t/rfc-6.1.1-capability.t b/t/rfc-6.1.1-capability.t
index eca5c1a..dc531e4 100644
--- a/t/rfc-6.1.1-capability.t
+++ b/t/rfc-6.1.1-capability.t
@@ -55,12 +55,9 @@ $t->cmd_ok("LOGIN username password", "Logged in");
"* CAPABILITY",
"tag OK",
);
-{
- local $TODO = "Is this correct?";
- like($cap, qr/\bIMAP4rev1\b/, "Advertises IMAP4rev1");
- like($cap, qr/\bAUTH=PLAIN\b/, "Advertises AUTH=PLAIN over TLS");
- unlike($cap, qr/\bSTARTTLS\b/, "TLS is not advertized over TLS");
- unlike($cap, qr/\bLOGINDISABLED\b/, "Login is not DISABLED over TLS");
-}
+like($cap, qr/\bIMAP4rev1\b/, "Advertises IMAP4rev1");
+unlike($cap, qr/\bAUTH=PLAIN\b/, "No longer advertises AUTH after login");
+unlike($cap, qr/\bSTARTTLS\b/, "TLS is not advertized over TLS");
+unlike($cap, qr/\bLOGINDISABLED\b/, "Login is not DISABLED over TLS");
done_testing;
commit 5a494013829e70fa67b58523243e89971d454f54
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Tue Dec 28 03:44:38 2010 -0500
Set per-process ports, so tests can run in parallel
diff --git a/inc/Net/IMAP/Server/Test.pm b/inc/Net/IMAP/Server/Test.pm
index dcc3e3d..aad8a54 100644
--- a/inc/Net/IMAP/Server/Test.pm
+++ b/inc/Net/IMAP/Server/Test.pm
@@ -6,8 +6,9 @@ use warnings;
use IO::Socket::SSL;
-use constant PORT => 7000;
-use constant SSL_PORT => 7001;
+my $PPID = $$;
+sub PORT() { 2000 + $PPID*2 }
+sub SSL_PORT() { 2001 + $PPID*2 }
sub import_extra {
my $class = shift;
commit c4950665cf86b945b1a76c2e3d1dbe2ca14a4012
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Tue Dec 28 03:46:42 2010 -0500
Replace ->socket->close with working ->server_close
There hasn't been a ->socket since we started using Net::Server::Coro
in b6f7350; use the equivilent ->server_close.
diff --git a/lib/Net/IMAP/Server.pm b/lib/Net/IMAP/Server.pm
index 576a3f3..1b9a8e5 100644
--- a/lib/Net/IMAP/Server.pm
+++ b/lib/Net/IMAP/Server.pm
@@ -276,7 +276,7 @@ listening sockets.
DESTROY {
my $self = shift;
$_->close for grep { defined $_ } @{ $self->connections };
- $self->socket->close if $self->socket;
+ $self->server_close;
}
=head2 connections
commit ba8657a54eacde14e44719d67aaac7ae8b23cb31
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Tue Dec 28 03:47:30 2010 -0500
During testing, gracefully exit if we get killed off
diff --git a/inc/Net/IMAP/Server/Test.pm b/inc/Net/IMAP/Server/Test.pm
index aad8a54..f2ca2fe 100644
--- a/inc/Net/IMAP/Server/Test.pm
+++ b/inc/Net/IMAP/Server/Test.pm
@@ -183,6 +183,7 @@ sub stop_server {
1 while wait > 0;
}
+$SIG{$_} = sub {exit} for qw/TERM INT QUIT/;
END { stop_server() }
1;
commit 85b7f7e7b244fc119b66d8b0a1405f6df441ea08
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Sun Mar 20 13:41:56 2011 -0700
Per RFC, deselection happens before checking selection validity
Thus, selecting a bogus mailbox leaves the connection in the UNSELECTED
state.
diff --git a/lib/Net/IMAP/Server/Command/Select.pm b/lib/Net/IMAP/Server/Command/Select.pm
index e746a8d..ed095cb 100644
--- a/lib/Net/IMAP/Server/Command/Select.pm
+++ b/lib/Net/IMAP/Server/Command/Select.pm
@@ -14,17 +14,21 @@ sub validate {
return $self->bad_command("Not enough options") if @options < 1;
return $self->bad_command("Too many options") if @options > 1;
- my $mailbox = $self->connection->model->lookup( @options );
- return $self->no_command("Mailbox does not exist") unless $mailbox;
- return $self->no_command("Mailbox is not selectable") unless $mailbox->is_selectable;
-
return 1;
}
sub run {
my $self = shift;
+ $self->connection->selected->expunge
+ if $self->connection->selected
+ and not $self->connection->selected->read_only;
+ $self->connection->selected(undef);
+
my $mailbox = $self->connection->model->lookup( $self->parsed_options );
+ return $self->no_command("Mailbox does not exist") unless $mailbox;
+ return $self->no_command("Mailbox is not selectable") unless $mailbox->is_selectable;
+
$mailbox->poll;
$self->connection->last_poll(time);
$self->connection->selected($mailbox, $self->command eq "Examine");
commit 759e6954e6bb6f2c4a9fae37729c3b50f8650eff
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Sun Mar 20 22:20:46 2011 -0400
Test basic SELECT functionality
diff --git a/t/rfc-6.3.1-select.t b/t/rfc-6.3.1-select.t
new file mode 100644
index 0000000..8fa1626
--- /dev/null
+++ b/t/rfc-6.3.1-select.t
@@ -0,0 +1,70 @@
+use lib 'inc';
+use strict;
+use warnings;
+
+use Net::IMAP::Server::Test;
+my $t = "Net::IMAP::Server::Test";
+
+$t->start_server_ok;
+for my $cmd (qw/SELECT EXAMINE/) {
+ $t->connect_ok;
+
+ $t->cmd_like( "$cmd INBOX" => "tag BAD Log in first" );
+
+ $t->cmd_ok("LOGIN username password");
+
+ $t->cmd_like( "$cmd" => "tag BAD Not enough options" );
+ $t->cmd_like( "$cmd foo bar" => "tag BAD Too many options" );
+ $t->cmd_like( "$cmd broken" => "tag NO Mailbox does not exist" );
+
+ # Can't do a FETCH before selecting/examining
+ $t->cmd_like( "FETCH 1:* UID" => "tag BAD Select a mailbox first" );
+
+ # Check that we have all of the simple requirements of the response
+ my @res = split /\r\n/, $t->send_cmd( "$cmd INBOX" );
+ # The tagged response has to be last
+ my $mode = ($cmd eq "SELECT") ? "READ-WRITE" : "READ-ONLY";
+ like( pop(@res), qr/^tag OK \[$mode\]/);
+ # But everything else can be in any order
+ is((grep /^\* FLAGS \(\\\S+(?:\s+\\\S+)*\)/, @res), 1, "Has FLAGS");
+ is((grep /^\* \d+ EXISTS\b/, @res), 1, "Has EXISTS");
+ is((grep /^\* \d+ RECENT\b/, @res), 1, "Has RECENT");
+ is((grep /^\* OK \[UNSEEN \d+\]/, @res), 1, "Has UNSEEN");
+ is((grep /^\* OK \[PERMANENTFLAGS \(\\\S+(?:\s+\\\S+)*\)\]/, @res), 1,
+ "Has PERMANENTFLAGS");
+ is((grep /^\* OK \[UIDNEXT \d+\]/, @res), 1, "Has UIDNEXT");
+ is((grep /^\* OK \[UIDVALIDITY \d+\]/, @res), 1, "Has UIDVALIDITY");
+
+ # Fetch works now
+ $t->cmd_like( "FETCH 1:* UID" => "tag OK FETCH COMPLETED" );
+
+ # Selecting/examining a bogus mailbox unselects the connection
+ $t->cmd_like( "$cmd broken" => "tag NO Mailbox does not exist" );
+ $t->cmd_like( "FETCH 1:* UID" => "tag BAD Select a mailbox first" );
+
+ # Test inbox case sensitivity
+ $t->cmd_ok( "$cmd INBOX" );
+ $t->cmd_ok( "$cmd inbox" );
+ my $res = $t->cmd_ok( "$cmd InBoX" );
+
+ # Check that FLAGS includes the expected
+ my %flags;
+ ok($res =~ /^\* FLAGS \((\\\S+(?:\s+\\\S+)*)\)/m, "Found flags");
+ $flags{$_}++ for split ' ', $1;
+ ok(delete $flags{$_}, "Has $_ flag")
+ for qw/\Answered \Flagged \Deleted \Seen \Draft/;
+ ok(!$flags{'\Recent'}, 'Lacks \Recent flag');
+
+ # Check that PERMANENTFLAGS includes the expected
+ %flags = ();
+ ok($res =~ /^\* OK \[PERMANENTFLAGS \((\\\S+(?:\s+\\\S+)*)\)\]/m, "Found permanentflags");
+ $flags{$_}++ for split ' ', $1;
+ ok(delete $flags{$_}, "Has $_ permanentflag")
+ for qw/\Answered \Flagged \Deleted \Seen \Draft/;
+ ok(!$flags{'\Recent'}, 'Lacks \Recent permanentflag');
+
+ $t->disconnect;
+}
+
+
+done_testing;
commit dd1a99f6fbbe7d785371bcdf3653fae481ea84a2
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Sun Mar 20 22:21:42 2011 -0400
Provide a helper method to list the current mailboxes during testing
diff --git a/inc/Net/IMAP/Server/Test.pm b/inc/Net/IMAP/Server/Test.pm
index f2ca2fe..fa96ca2 100644
--- a/inc/Net/IMAP/Server/Test.pm
+++ b/inc/Net/IMAP/Server/Test.pm
@@ -176,6 +176,18 @@ sub _send_like {
return wantarray ? @got : $response;
}
+sub mailbox_list {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my $class = shift;
+ my ($base, $pattern) = @_;
+ $base ||= "";
+ $pattern ||= "*";
+ my $ret = $class->send_cmd(qq{LIST "$base" "$pattern"});
+ my %mailboxes;
+ $mailboxes{$2} = $1 while $ret =~ m{^\* LIST \((\\\S+(?:\s+\\\S+)*)\) "/" "(.*?)"}mg;
+ return %mailboxes;
+}
+
sub stop_server {
return unless $pid;
local $?;
commit 7ae056eabb917ad79adb3780d0123350292a1d61
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Sun Mar 20 22:23:38 2011 -0400
Forbid 8-bit mailbox names, per RFC
diff --git a/lib/Net/IMAP/Server/Command/Create.pm b/lib/Net/IMAP/Server/Command/Create.pm
index 67a2c97..d70e1a7 100644
--- a/lib/Net/IMAP/Server/Command/Create.pm
+++ b/lib/Net/IMAP/Server/Command/Create.pm
@@ -17,6 +17,10 @@ sub validate {
my $mailbox = $self->connection->model->lookup( @options );
return $self->no_command("Mailbox already exists") if $mailbox;
+ # Check for high-bit characters
+ return $self->bad_command("Mailbox name contains 8-bit data")
+ if $name =~ /[\x80-\xFF]/;
+
# This both ensures that the mailbox path is valid UTF-7, and that
# there aren't bogusly encoded characters (like '/' -> '&AC8-')
my $roundtrip = eval {
commit 8961a34023004988fd7c90850faf9afc008ad4fa
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Sun Mar 20 22:24:02 2011 -0400
Note that $model->split may die()
diff --git a/lib/Net/IMAP/Server/DefaultModel.pm b/lib/Net/IMAP/Server/DefaultModel.pm
index 454b8ab..fad1b23 100644
--- a/lib/Net/IMAP/Server/DefaultModel.pm
+++ b/lib/Net/IMAP/Server/DefaultModel.pm
@@ -123,7 +123,8 @@ sub split {
=head2 lookup PATH
Given a C<PATH>, returns the L<Net::IMAP::Server::Mailbox> for that
-path, or undef if none matches.
+path, or undef if none matches. May die if the path contains unvalid
+IMAP-UTF-7 (see L</split>).
=cut
commit e81de697ad968e08da560bcf597d152fd10779ca
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Sun Mar 20 22:24:23 2011 -0400
Test RFC specification of CREATE
diff --git a/t/rfc-6.3.3-create.t b/t/rfc-6.3.3-create.t
new file mode 100644
index 0000000..79d2069
--- /dev/null
+++ b/t/rfc-6.3.3-create.t
@@ -0,0 +1,76 @@
+use lib 'inc';
+use strict;
+use warnings;
+
+use Net::IMAP::Server::Test;
+my $t = "Net::IMAP::Server::Test";
+
+$t->start_server_ok;
+$t->connect_ok;
+
+$t->cmd_like("CREATE foo" => "tag BAD Log in first" );
+
+$t->cmd_ok("LOGIN username password");
+
+$t->cmd_like("CREATE" => "tag BAD Not enough options" );
+$t->cmd_like("CREATE foo bar" => "tag BAD Too many options" );
+
+# We assume a "/" separator here
+my $res = $t->cmd_ok( 'LIST "" ""');
+ok($res =~ m{^\* LIST \(\\Noselect\) "/" ""\r\n}m, "Separator is /");
+
+# Check starting state
+my %mailboxes = $t->mailbox_list;
+is(delete $mailboxes{"INBOX"}, "\\HasChildren",
+ "INBOX exists");
+is(delete $mailboxes{"INBOX/username"}, "\\HasNoChildren",
+ "INBOX/username exists");
+is(keys %mailboxes, 0, "No other mailboxes");
+
+# Create a new top-level mailbox
+$t->cmd_ok("CREATE moose");
+%mailboxes = $t->mailbox_list;
+is(delete $mailboxes{"moose"}, "\\HasNoChildren",
+ "moose now exists");
+is(keys %mailboxes, 2, "No other mailboxes created");
+
+# Creating a subfolder marks the parent as \HasChildren
+$t->cmd_ok("CREATE moose/thingy");
+%mailboxes = $t->mailbox_list;
+is($mailboxes{"moose"}, "\\HasChildren",
+ "moose now has children");
+is($mailboxes{"moose/thingy"}, "\\HasNoChildren",
+ "moose/thingy now exists");
+
+# Creating a folder with a trailing separator strips it off
+$t->cmd_ok("CREATE trailing/");
+%mailboxes = $t->mailbox_list;
+is(delete $mailboxes{"trailing"}, "\\HasNoChildren",
+ "Trailing slash is removed");
+is(keys %mailboxes, 4, "No other mailboxes created");
+
+# Creating a deep mailbox creates all of its parents
+$t->cmd_ok("CREATE deeply/nested/folder");
+%mailboxes = $t->mailbox_list;
+is(delete $mailboxes{"deeply"}, "\\HasChildren",
+ "First level created");
+is(delete $mailboxes{"deeply/nested"}, "\\HasChildren",
+ "Second level created");
+is(delete $mailboxes{"deeply/nested/folder"}, "\\HasNoChildren",
+ "Third level created");
+
+# Invalid IMAP-UTF-7 fails
+$t->cmd_like('CREATE "INBOX/&Jjo!"', qr/BAD Invalid UTF-7/ );
+$t->cmd_like('CREATE "INBOX/&U,BTFw-&ZeVnLIqe-"', qr/BAD Invalid UTF-7/ );
+
+# UTF-8 mailbox names fail
+$t->cmd_like(qq{CREATE "INBOX/\x{2668}"}, qr/BAD Mailbox name contains 8-bit data/);
+
+# Creating over an existing mailbox fails
+$t->cmd_like("CREATE moose" => qr/NO Mailbox already exists/);
+
+# This is true even for the magic case-insensitive INBOX
+$t->cmd_like("CREATE INBOX" => qr/NO Mailbox already exists/);
+$t->cmd_like("CREATE InBoX" => qr/NO Mailbox already exists/);
+
+done_testing;
commit 47965368b77c6cf1b04cc6bb1dd5af8120e9b64a
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Sun Mar 20 22:25:07 2011 -0400
Removing INBOX is forbidden, per RFC
diff --git a/lib/Net/IMAP/Server/Command/Delete.pm b/lib/Net/IMAP/Server/Command/Delete.pm
index c832b7e..34349bc 100644
--- a/lib/Net/IMAP/Server/Command/Delete.pm
+++ b/lib/Net/IMAP/Server/Command/Delete.pm
@@ -16,6 +16,7 @@ sub validate {
my $mailbox = $self->connection->model->lookup( @options );
return $self->no_command("Mailbox doesn't exist") unless $mailbox;
+ return $self->no_command("INBOX cannot be deleted") if $mailbox->is_inbox;
return $self->no_command("Mailbox has children") if @{$mailbox->children};
return 1;
commit 4c0bf897c36fdb55fa95d5803c6d2934b1f4b993
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Sun Mar 20 22:25:47 2011 -0400
Test RFC specification of DELETE
Note TODO tests concerning nested folders, and RFC inconsistency thereof
diff --git a/t/rfc-6.3.4-delete.t b/t/rfc-6.3.4-delete.t
new file mode 100644
index 0000000..5224214
--- /dev/null
+++ b/t/rfc-6.3.4-delete.t
@@ -0,0 +1,66 @@
+use lib 'inc';
+use strict;
+use warnings;
+
+use Net::IMAP::Server::Test;
+my $t = "Net::IMAP::Server::Test";
+
+$t->start_server_ok;
+$t->connect_ok;
+
+$t->cmd_like("DELETE foo" => "tag BAD Log in first" );
+
+$t->cmd_ok("LOGIN username password");
+
+$t->cmd_like("DELETE" => "tag BAD Not enough options" );
+$t->cmd_like("DELETE foo bar" => "tag BAD Too many options" );
+
+# Prune INBOX/username
+$t->cmd_ok("DELETE INBOX/username");
+my %mailboxes = $t->mailbox_list;
+is(delete $mailboxes{"INBOX"}, "\\HasNoChildren",
+ "INBOX exists");
+is(keys %mailboxes, 0, "No other mailboxes");
+
+# Removing a non-existant mailbox is a failure
+$t->cmd_like("DELETE bogus" => "tag NO Mailbox doesn't exist");
+
+# Removing the INBOX (in any case) is a failure
+$t->cmd_like("DELETE INBOX" => "tag NO INBOX cannot be deleted");
+$t->cmd_like("DELETE InBoX" => "tag NO INBOX cannot be deleted");
+
+# The RFC is slightly inconsistent with how removing a mailbox with
+# inferiors should function:
+# * Messages are removed from the mailbox
+# * The mailbox is marked as \Noselect
+# * Per the _first_ example under 6.3.4, this mailbox still shows to
+# `LIST "" "*"`; however, per the second, it does _not_ -- only to
+# `LIST "" "%"`. While the RENAME example supports the former
+# interpretation, the explicit contrast of * to % in the second
+# DELETE example implies that it is intentional.
+# * Removing this \Noselect'd mailbox will fail in the future
+# Currently, Net::IMAP::Server simply refuses to remove mailboxes which
+# have inferiors, avoiding the \Noselect difficulty entirely.
+$t->cmd_ok("CREATE INBOX/with/children");
+{
+ local $TODO = "Mailbox deletion is still too-conservative";
+ $t->cmd_ok("DELETE INBOX/with");
+}
+%mailboxes = $t->mailbox_list;
+is(delete $mailboxes{"INBOX/with/children"}, "\\HasNoChildren",
+ "Inferior mailbox still exists");
+{
+ local $TODO = "Mailbox deletion is still too-conservative";
+ ok(!$mailboxes{"INBOX/with"}, "Mailbox is gone");
+ is(keys %mailboxes, 1, "No other mailboxes");
+}
+%mailboxes = $t->mailbox_list("", "INBOX/%");
+my $mid = delete $mailboxes{"INBOX/with"};
+ok($mid, "Found mid-mailbox using %");
+like($mid, qr/\\HasChildren/, "Is marked \\HasChildren");
+{
+ local $TODO = "Mailbox deletion is still too-conservative";
+ like($mid, qr/\\Noselect/, "Is marked \\Noselect");
+}
+
+done_testing;
commit aa3d3d0b8d459acd3b0654c0b88897eb7686de89
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Sun Mar 20 22:26:48 2011 -0400
Refactor UTF-7 and 8-bit mailbox name checking out of Create
diff --git a/lib/Net/IMAP/Server/Command.pm b/lib/Net/IMAP/Server/Command.pm
index 0e7606c..15c5c41 100644
--- a/lib/Net/IMAP/Server/Command.pm
+++ b/lib/Net/IMAP/Server/Command.pm
@@ -374,6 +374,35 @@ sub bad_command {
return 0;
}
+=head2 valid_mailbox NAME
+
+Returns false and calls L</bad_command> if the given C<NAME> is a valid
+name for a mailbox. This only checks that is passes UTF-7 encoding
+checks, and that it contains no 8-bit characters. If the name is valid,
+simply returns 1.
+
+=cut
+
+sub valid_mailbox {
+ my $self = shift;
+ my ($name) = @_;
+
+ # Check for high-bit characters
+ return $self->bad_command("Mailbox name contains 8-bit data")
+ if $name =~ /[\x80-\xFF]/;
+
+ # This both ensures that the mailbox path is valid UTF-7, and that
+ # there aren't bogusly encoded characters (like '/' -> '&AC8-')
+ my $roundtrip = eval {
+ Encode::encode( 'IMAP-UTF-7',
+ Encode::decode( 'IMAP-UTF-7', $name ) );
+ };
+ return $self->bad_command("Invalid UTF-7 encoding")
+ unless defined $roundtrip and $roundtrip eq $name;
+
+ return 1;
+}
+
=head2 log SEVERITY, MESSAGE
Defers to L<Net::IMAP::Server::Connection/log>.
diff --git a/lib/Net/IMAP/Server/Command/Create.pm b/lib/Net/IMAP/Server/Command/Create.pm
index d70e1a7..0906003 100644
--- a/lib/Net/IMAP/Server/Command/Create.pm
+++ b/lib/Net/IMAP/Server/Command/Create.pm
@@ -17,21 +17,7 @@ sub validate {
my $mailbox = $self->connection->model->lookup( @options );
return $self->no_command("Mailbox already exists") if $mailbox;
- # Check for high-bit characters
- return $self->bad_command("Mailbox name contains 8-bit data")
- if $name =~ /[\x80-\xFF]/;
-
- # This both ensures that the mailbox path is valid UTF-7, and that
- # there aren't bogusly encoded characters (like '/' -> '&AC8-')
- my $roundtrip = eval {
- Encode::encode( 'IMAP-UTF-7',
- Encode::decode( 'IMAP-UTF-7', $options[0] ) );
- };
-
- return $self->bad_command("Invalid UTF-7 encoding")
- unless $roundtrip eq $options[0];
-
- return 1;
+ return $self->valid_mailbox($options[0]);
}
sub run {
commit 81e26b2f5966680a8ef2f55808dda7b149a50b93
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Sun Mar 20 22:27:08 2011 -0400
Ensure that the new mailbox name in RENAME is also legit
diff --git a/lib/Net/IMAP/Server/Command/Rename.pm b/lib/Net/IMAP/Server/Command/Rename.pm
index fa9f2ee..98c6eab 100644
--- a/lib/Net/IMAP/Server/Command/Rename.pm
+++ b/lib/Net/IMAP/Server/Command/Rename.pm
@@ -20,7 +20,8 @@ sub validate {
my $newbox = $self->connection->model->lookup($new);
return $self->no_command("Mailbox already exists") if $newbox;
- return 1;
+ # Test that the new name is valid
+ return $self->valid_mailbox($new);
}
sub run {
commit ea2a57246ae7d1361653769aa015b4354649b775
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Sun Mar 20 22:27:49 2011 -0400
Test RFC specification of RENAME
diff --git a/t/rfc-6.3.5-rename.t b/t/rfc-6.3.5-rename.t
new file mode 100644
index 0000000..4d8ffa4
--- /dev/null
+++ b/t/rfc-6.3.5-rename.t
@@ -0,0 +1,68 @@
+use lib 'inc';
+use strict;
+use warnings;
+
+use Net::IMAP::Server::Test;
+my $t = "Net::IMAP::Server::Test";
+
+$t->start_server_ok;
+$t->connect_ok;
+
+$t->cmd_like("RENAME foo bar" => "tag BAD Log in first" );
+
+$t->cmd_ok("LOGIN username password");
+
+$t->cmd_like("RENAME" => "tag BAD Not enough options" );
+$t->cmd_like("RENAME foo" => "tag BAD Not enough options" );
+$t->cmd_like("RENAME foo bar baz" => "tag BAD Too many options" );
+
+# Simple rename
+$t->cmd_ok("CREATE moose");
+$t->cmd_ok("RENAME moose thingy");
+my %mailboxes = $t->mailbox_list;
+ok(!exists $mailboxes{"moose"}, "Old mailbox no longer exists");
+ok(exists $mailboxes{"thingy"}, "New mailbox exists");
+
+# Renaming a mailbox to that doesn't exist fails
+$t->cmd_like("RENAME bogus nonexistant", "tag NO Mailbox doesn't exist");
+
+# Renaming a mailbox to one that exists already is an error
+$t->cmd_ok("CREATE bogus");
+$t->cmd_like("RENAME bogus thingy", "tag NO Mailbox already exists");
+
+# Renaming a folder moves all subfolders
+$t->cmd_ok("CREATE old/folder");
+$t->cmd_ok("RENAME old new");
+%mailboxes = $t->mailbox_list;
+ok(!exists $mailboxes{"old"}, "Old mailbox no longer exists");
+ok(exists $mailboxes{"new"}, "New mailbox exists");
+ok(!exists $mailboxes{"old/folder"}, "Old subfolder no longer exists");
+ok(exists $mailboxes{"new/folder"}, "New subfolder exists");
+
+# Renaming creates any hierarchy necessary
+$t->cmd_ok("RENAME new/folder deep/folder");
+%mailboxes = $t->mailbox_list;
+ok(!exists $mailboxes{"new/folder"}, "Old mailbox no longer exists");
+ok(exists $mailboxes{"new"}, "Old mailbox's parent still longer exists");
+ok(exists $mailboxes{"deep"}, "Parent folder created");
+ok(exists $mailboxes{"deep/folder"}, "Subfolder created");
+
+# Renaming INBOX is magic
+$t->cmd_ok("RENAME INBOX newinbox");
+%mailboxes = $t->mailbox_list;
+ok(exists $mailboxes{"newinbox"}, "newinbox now exists");
+{
+ local $TODO = "Moving INBOX is broken";
+ ok(exists $mailboxes{"INBOX"}, "INBOX still exists");
+ ok(exists $mailboxes{"INBOX/username"}, "INBOX's subfolders still exist");
+ ok(!exists $mailboxes{"newinbox/username"}, "newinbox doesn't have INBOX's subfolder");
+}
+
+# Renaming to a bad UTF-7 name is an error
+$t->cmd_like('RENAME bogus "INBOX/&Jjo!"', qr/BAD Invalid UTF-7/ );
+$t->cmd_like('RENAME bogus "INBOX/&U,BTFw-&ZeVnLIqe-"', qr/BAD Invalid UTF-7/ );
+
+# Renaming to an 8-bit name is an error
+$t->cmd_like(qq{RENAME bogus "INBOX/\x{2668}"}, qr/BAD Mailbox name contains 8-bit data/);
+
+done_testing;
commit 0ad3f735c791843d24131f313327b5ce077ea89a
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Sun Mar 20 22:49:54 2011 -0400
Move testing libraries from inc/ to t/lib/
diff --git a/t/01-connect.t b/t/01-connect.t
index 2e55032..8e87403 100644
--- a/t/01-connect.t
+++ b/t/01-connect.t
@@ -1,4 +1,4 @@
-use lib 'inc';
+use lib 't/lib';
use strict;
use warnings;
diff --git a/inc/Net/IMAP/Server/Test.pm b/t/lib/Net/IMAP/Server/Test.pm
similarity index 100%
rename from inc/Net/IMAP/Server/Test.pm
rename to t/lib/Net/IMAP/Server/Test.pm
diff --git a/inc/Net/IMAP/Server/Test/Auth.pm b/t/lib/Net/IMAP/Server/Test/Auth.pm
similarity index 100%
rename from inc/Net/IMAP/Server/Test/Auth.pm
rename to t/lib/Net/IMAP/Server/Test/Auth.pm
diff --git a/inc/Net/IMAP/Server/Test/Server.pm b/t/lib/Net/IMAP/Server/Test/Server.pm
similarity index 100%
rename from inc/Net/IMAP/Server/Test/Server.pm
rename to t/lib/Net/IMAP/Server/Test/Server.pm
diff --git a/t/rfc-6.1.1-capability.t b/t/rfc-6.1.1-capability.t
index dc531e4..be86e36 100644
--- a/t/rfc-6.1.1-capability.t
+++ b/t/rfc-6.1.1-capability.t
@@ -1,4 +1,4 @@
-use lib 'inc';
+use lib 't/lib';
use strict;
use warnings;
diff --git a/t/rfc-6.1.2-noop.t b/t/rfc-6.1.2-noop.t
index 708e95f..d22959d 100644
--- a/t/rfc-6.1.2-noop.t
+++ b/t/rfc-6.1.2-noop.t
@@ -1,4 +1,4 @@
-use lib 'inc';
+use lib 't/lib';
use strict;
use warnings;
diff --git a/t/rfc-6.1.3-logout.t b/t/rfc-6.1.3-logout.t
index a4bf6fe..58b1e7e 100644
--- a/t/rfc-6.1.3-logout.t
+++ b/t/rfc-6.1.3-logout.t
@@ -1,4 +1,4 @@
-use lib 'inc';
+use lib 't/lib';
use strict;
use warnings;
diff --git a/t/rfc-6.2.1-starttls.t b/t/rfc-6.2.1-starttls.t
index ddafdd7..16e13f1 100644
--- a/t/rfc-6.2.1-starttls.t
+++ b/t/rfc-6.2.1-starttls.t
@@ -1,4 +1,4 @@
-use lib 'inc';
+use lib 't/lib';
use strict;
use warnings;
diff --git a/t/rfc-6.2.2-authenticate.t b/t/rfc-6.2.2-authenticate.t
index 0933b4a..11f2f5f 100644
--- a/t/rfc-6.2.2-authenticate.t
+++ b/t/rfc-6.2.2-authenticate.t
@@ -1,4 +1,4 @@
-use lib 'inc';
+use lib 't/lib';
use strict;
use warnings;
diff --git a/t/rfc-6.2.3-login.t b/t/rfc-6.2.3-login.t
index 89e0505..df49c9c 100644
--- a/t/rfc-6.2.3-login.t
+++ b/t/rfc-6.2.3-login.t
@@ -1,4 +1,4 @@
-use lib 'inc';
+use lib 't/lib';
use strict;
use warnings;
diff --git a/t/rfc-6.3.1-select.t b/t/rfc-6.3.1-select.t
index 8fa1626..534b7ca 100644
--- a/t/rfc-6.3.1-select.t
+++ b/t/rfc-6.3.1-select.t
@@ -1,4 +1,4 @@
-use lib 'inc';
+use lib 't/lib';
use strict;
use warnings;
diff --git a/t/rfc-6.3.3-create.t b/t/rfc-6.3.3-create.t
index 79d2069..3bc8e5b 100644
--- a/t/rfc-6.3.3-create.t
+++ b/t/rfc-6.3.3-create.t
@@ -1,4 +1,4 @@
-use lib 'inc';
+use lib 't/lib';
use strict;
use warnings;
diff --git a/t/rfc-6.3.4-delete.t b/t/rfc-6.3.4-delete.t
index 5224214..23a0c05 100644
--- a/t/rfc-6.3.4-delete.t
+++ b/t/rfc-6.3.4-delete.t
@@ -1,4 +1,4 @@
-use lib 'inc';
+use lib 't/lib';
use strict;
use warnings;
diff --git a/t/rfc-6.3.5-rename.t b/t/rfc-6.3.5-rename.t
index 4d8ffa4..ed40990 100644
--- a/t/rfc-6.3.5-rename.t
+++ b/t/rfc-6.3.5-rename.t
@@ -1,4 +1,4 @@
-use lib 'inc';
+use lib 't/lib';
use strict;
use warnings;
commit e89ec152cbe4676ff1e4c5b341924d5187a1671e
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Sun Mar 20 22:50:50 2011 -0400
Remove and ignore generated files
diff --git a/.gitignore b/.gitignore
index 4a0d32b..ebb6c96 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,5 +1,7 @@
+META.yml
Makefile
Makefile.old
blib
pm_to_blib
+inc
Net-IMAP-Server-*.tar.gz
diff --git a/META.yml b/META.yml
deleted file mode 100644
index 18b6bfd..0000000
--- a/META.yml
+++ /dev/null
@@ -1,40 +0,0 @@
----
-abstract: 'A single-threaded multiplexing IMAP server'
-author:
- - 'Alex Vandiver <alexmv at mit.edu>'
-build_requires:
- ExtUtils::MakeMaker: 6.42
-configure_requires:
- ExtUtils::MakeMaker: 6.42
-distribution_type: module
-generated_by: 'Module::Install version 0.95'
-license: perl
-meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.4.html
- version: 1.4
-name: Net-IMAP-Server
-no_index:
- directory:
- - inc
- - t
-requires:
- Class::Accessor: 0
- Coro: 0
- DateTime: 0
- DateTime::Format::Mail: 0
- DateTime::Format::Strptime: 0
- Email::Address: 0
- Email::MIME: 1.862
- Email::MIME::ContentType: 0
- Email::Simple: 1.999
- Encode::IMAPUTF7: 0
- MIME::Base64: 0
- Net::SSLeay: 0
- Net::Server::Coro: 0.6
- Regexp::Common: 0
- Test::More: 0
- UNIVERSAL::require: 0
-resources:
- license: http://dev.perl.org/licenses/
- repository: http://github.com/bestpractical/net-imap-server/
-version: 1.28
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
deleted file mode 100644
index bc055a9..0000000
--- a/inc/Module/Install.pm
+++ /dev/null
@@ -1,441 +0,0 @@
-#line 1
-package Module::Install;
-
-# For any maintainers:
-# The load order for Module::Install is a bit magic.
-# It goes something like this...
-#
-# IF ( host has Module::Install installed, creating author mode ) {
-# 1. Makefile.PL calls "use inc::Module::Install"
-# 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
-# 3. The installed version of inc::Module::Install loads
-# 4. inc::Module::Install calls "require Module::Install"
-# 5. The ./inc/ version of Module::Install loads
-# } ELSE {
-# 1. Makefile.PL calls "use inc::Module::Install"
-# 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
-# 3. The ./inc/ version of Module::Install loads
-# }
-
-use 5.005;
-use strict 'vars';
-use Cwd ();
-use File::Find ();
-use File::Path ();
-use FindBin;
-
-use vars qw{$VERSION $MAIN};
-BEGIN {
- # All Module::Install core packages now require synchronised versions.
- # This will be used to ensure we don't accidentally load old or
- # different versions of modules.
- # This is not enforced yet, but will be some time in the next few
- # releases once we can make sure it won't clash with custom
- # Module::Install extensions.
- $VERSION = '0.95';
-
- # Storage for the pseudo-singleton
- $MAIN = undef;
-
- *inc::Module::Install::VERSION = *VERSION;
- @inc::Module::Install::ISA = __PACKAGE__;
-
-}
-
-sub import {
- my $class = shift;
- my $self = $class->new(@_);
- my $who = $self->_caller;
-
- #-------------------------------------------------------------
- # all of the following checks should be included in import(),
- # to allow "eval 'require Module::Install; 1' to test
- # installation of Module::Install. (RT #51267)
- #-------------------------------------------------------------
-
- # Whether or not inc::Module::Install is actually loaded, the
- # $INC{inc/Module/Install.pm} is what will still get set as long as
- # the caller loaded module this in the documented manner.
- # If not set, the caller may NOT have loaded the bundled version, and thus
- # they may not have a MI version that works with the Makefile.PL. This would
- # result in false errors or unexpected behaviour. And we don't want that.
- my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
- unless ( $INC{$file} ) { die <<"END_DIE" }
-
-Please invoke ${\__PACKAGE__} with:
-
- use inc::${\__PACKAGE__};
-
-not:
-
- use ${\__PACKAGE__};
-
-END_DIE
-
- # This reportedly fixes a rare Win32 UTC file time issue, but
- # as this is a non-cross-platform XS module not in the core,
- # we shouldn't really depend on it. See RT #24194 for detail.
- # (Also, this module only supports Perl 5.6 and above).
- eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006;
-
- # If the script that is loading Module::Install is from the future,
- # then make will detect this and cause it to re-run over and over
- # again. This is bad. Rather than taking action to touch it (which
- # is unreliable on some platforms and requires write permissions)
- # for now we should catch this and refuse to run.
- if ( -f $0 ) {
- my $s = (stat($0))[9];
-
- # If the modification time is only slightly in the future,
- # sleep briefly to remove the problem.
- my $a = $s - time;
- if ( $a > 0 and $a < 5 ) { sleep 5 }
-
- # Too far in the future, throw an error.
- my $t = time;
- if ( $s > $t ) { die <<"END_DIE" }
-
-Your installer $0 has a modification time in the future ($s > $t).
-
-This is known to create infinite loops in make.
-
-Please correct this, then run $0 again.
-
-END_DIE
- }
-
-
- # Build.PL was formerly supported, but no longer is due to excessive
- # difficulty in implementing every single feature twice.
- if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
-
-Module::Install no longer supports Build.PL.
-
-It was impossible to maintain duel backends, and has been deprecated.
-
-Please remove all Build.PL files and only use the Makefile.PL installer.
-
-END_DIE
-
- #-------------------------------------------------------------
-
- # To save some more typing in Module::Install installers, every...
- # use inc::Module::Install
- # ...also acts as an implicit use strict.
- $^H |= strict::bits(qw(refs subs vars));
-
- #-------------------------------------------------------------
-
- unless ( -f $self->{file} ) {
- require "$self->{path}/$self->{dispatch}.pm";
- File::Path::mkpath("$self->{prefix}/$self->{author}");
- $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
- $self->{admin}->init;
- @_ = ($class, _self => $self);
- goto &{"$self->{name}::import"};
- }
-
- *{"${who}::AUTOLOAD"} = $self->autoload;
- $self->preload;
-
- # Unregister loader and worker packages so subdirs can use them again
- delete $INC{"$self->{file}"};
- delete $INC{"$self->{path}.pm"};
-
- # Save to the singleton
- $MAIN = $self;
-
- return 1;
-}
-
-sub autoload {
- my $self = shift;
- my $who = $self->_caller;
- my $cwd = Cwd::cwd();
- my $sym = "${who}::AUTOLOAD";
- $sym->{$cwd} = sub {
- my $pwd = Cwd::cwd();
- if ( my $code = $sym->{$pwd} ) {
- # Delegate back to parent dirs
- goto &$code unless $cwd eq $pwd;
- }
- $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
- my $method = $1;
- if ( uc($method) eq $method ) {
- # Do nothing
- return;
- } elsif ( $method =~ /^_/ and $self->can($method) ) {
- # Dispatch to the root M:I class
- return $self->$method(@_);
- }
-
- # Dispatch to the appropriate plugin
- unshift @_, ( $self, $1 );
- goto &{$self->can('call')};
- };
-}
-
-sub preload {
- my $self = shift;
- unless ( $self->{extensions} ) {
- $self->load_extensions(
- "$self->{prefix}/$self->{path}", $self
- );
- }
-
- my @exts = @{$self->{extensions}};
- unless ( @exts ) {
- @exts = $self->{admin}->load_all_extensions;
- }
-
- my %seen;
- foreach my $obj ( @exts ) {
- while (my ($method, $glob) = each %{ref($obj) . '::'}) {
- next unless $obj->can($method);
- next if $method =~ /^_/;
- next if $method eq uc($method);
- $seen{$method}++;
- }
- }
-
- my $who = $self->_caller;
- foreach my $name ( sort keys %seen ) {
- *{"${who}::$name"} = sub {
- ${"${who}::AUTOLOAD"} = "${who}::$name";
- goto &{"${who}::AUTOLOAD"};
- };
- }
-}
-
-sub new {
- my ($class, %args) = @_;
-
- # ignore the prefix on extension modules built from top level.
- my $base_path = Cwd::abs_path($FindBin::Bin);
- unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
- delete $args{prefix};
- }
-
- return $args{_self} if $args{_self};
-
- $args{dispatch} ||= 'Admin';
- $args{prefix} ||= 'inc';
- $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
- $args{bundle} ||= 'inc/BUNDLES';
- $args{base} ||= $base_path;
- $class =~ s/^\Q$args{prefix}\E:://;
- $args{name} ||= $class;
- $args{version} ||= $class->VERSION;
- unless ( $args{path} ) {
- $args{path} = $args{name};
- $args{path} =~ s!::!/!g;
- }
- $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
- $args{wrote} = 0;
-
- bless( \%args, $class );
-}
-
-sub call {
- my ($self, $method) = @_;
- my $obj = $self->load($method) or return;
- splice(@_, 0, 2, $obj);
- goto &{$obj->can($method)};
-}
-
-sub load {
- my ($self, $method) = @_;
-
- $self->load_extensions(
- "$self->{prefix}/$self->{path}", $self
- ) unless $self->{extensions};
-
- foreach my $obj (@{$self->{extensions}}) {
- return $obj if $obj->can($method);
- }
-
- my $admin = $self->{admin} or die <<"END_DIE";
-The '$method' method does not exist in the '$self->{prefix}' path!
-Please remove the '$self->{prefix}' directory and run $0 again to load it.
-END_DIE
-
- my $obj = $admin->load($method, 1);
- push @{$self->{extensions}}, $obj;
-
- $obj;
-}
-
-sub load_extensions {
- my ($self, $path, $top) = @_;
-
- unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
- unshift @INC, $self->{prefix};
- }
-
- foreach my $rv ( $self->find_extensions($path) ) {
- my ($file, $pkg) = @{$rv};
- next if $self->{pathnames}{$pkg};
-
- local $@;
- my $new = eval { require $file; $pkg->can('new') };
- unless ( $new ) {
- warn $@ if $@;
- next;
- }
- $self->{pathnames}{$pkg} = delete $INC{$file};
- push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
- }
-
- $self->{extensions} ||= [];
-}
-
-sub find_extensions {
- my ($self, $path) = @_;
-
- my @found;
- File::Find::find( sub {
- my $file = $File::Find::name;
- return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
- my $subpath = $1;
- return if lc($subpath) eq lc($self->{dispatch});
-
- $file = "$self->{path}/$subpath.pm";
- my $pkg = "$self->{name}::$subpath";
- $pkg =~ s!/!::!g;
-
- # If we have a mixed-case package name, assume case has been preserved
- # correctly. Otherwise, root through the file to locate the case-preserved
- # version of the package name.
- if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
- my $content = Module::Install::_read($subpath . '.pm');
- my $in_pod = 0;
- foreach ( split //, $content ) {
- $in_pod = 1 if /^=\w/;
- $in_pod = 0 if /^=cut/;
- next if ($in_pod || /^=cut/); # skip pod text
- next if /^\s*#/; # and comments
- if ( m/^\s*package\s+($pkg)\s*;/i ) {
- $pkg = $1;
- last;
- }
- }
- }
-
- push @found, [ $file, $pkg ];
- }, $path ) if -d $path;
-
- @found;
-}
-
-
-
-
-
-#####################################################################
-# Common Utility Functions
-
-sub _caller {
- my $depth = 0;
- my $call = caller($depth);
- while ( $call eq __PACKAGE__ ) {
- $depth++;
- $call = caller($depth);
- }
- return $call;
-}
-
-# Done in evals to avoid confusing Perl::MinimumVersion
-eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
-sub _read {
- local *FH;
- open( FH, '<', $_[0] ) or die "open($_[0]): $!";
- my $string = do { local $/; <FH> };
- close FH or die "close($_[0]): $!";
- return $string;
-}
-END_NEW
-sub _read {
- local *FH;
- open( FH, "< $_[0]" ) or die "open($_[0]): $!";
- my $string = do { local $/; <FH> };
- close FH or die "close($_[0]): $!";
- return $string;
-}
-END_OLD
-
-sub _readperl {
- my $string = Module::Install::_read($_[0]);
- $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
- $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
- $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
- return $string;
-}
-
-sub _readpod {
- my $string = Module::Install::_read($_[0]);
- $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
- return $string if $_[0] =~ /\.pod\z/;
- $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
- $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
- $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
- $string =~ s/^\n+//s;
- return $string;
-}
-
-# Done in evals to avoid confusing Perl::MinimumVersion
-eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
-sub _write {
- local *FH;
- open( FH, '>', $_[0] ) or die "open($_[0]): $!";
- foreach ( 1 .. $#_ ) {
- print FH $_[$_] or die "print($_[0]): $!";
- }
- close FH or die "close($_[0]): $!";
-}
-END_NEW
-sub _write {
- local *FH;
- open( FH, "> $_[0]" ) or die "open($_[0]): $!";
- foreach ( 1 .. $#_ ) {
- print FH $_[$_] or die "print($_[0]): $!";
- }
- close FH or die "close($_[0]): $!";
-}
-END_OLD
-
-# _version is for processing module versions (eg, 1.03_05) not
-# Perl versions (eg, 5.8.1).
-sub _version ($) {
- my $s = shift || 0;
- my $d =()= $s =~ /(\.)/g;
- if ( $d >= 2 ) {
- # Normalise multipart versions
- $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
- }
- $s =~ s/^(\d+)\.?//;
- my $l = $1 || 0;
- my @v = map {
- $_ . '0' x (3 - length $_)
- } $s =~ /(\d{1,3})\D?/g;
- $l = $l . '.' . join '', @v if @v;
- return $l + 0;
-}
-
-sub _cmp ($$) {
- _version($_[0]) <=> _version($_[1]);
-}
-
-# Cloned from Params::Util::_CLASS
-sub _CLASS ($) {
- (
- defined $_[0]
- and
- ! ref $_[0]
- and
- $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
- ) ? $_[0] : undef;
-}
-
-1;
-
-# Copyright 2008 - 2010 Adam Kennedy.
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
deleted file mode 100644
index 4224c4d..0000000
--- a/inc/Module/Install/Base.pm
+++ /dev/null
@@ -1,78 +0,0 @@
-#line 1
-package Module::Install::Base;
-
-use strict 'vars';
-use vars qw{$VERSION};
-BEGIN {
- $VERSION = '0.95';
-}
-
-# Suspend handler for "redefined" warnings
-BEGIN {
- my $w = $SIG{__WARN__};
- $SIG{__WARN__} = sub { $w };
-}
-
-#line 42
-
-sub new {
- my $class = shift;
- unless ( defined &{"${class}::call"} ) {
- *{"${class}::call"} = sub { shift->_top->call(@_) };
- }
- unless ( defined &{"${class}::load"} ) {
- *{"${class}::load"} = sub { shift->_top->load(@_) };
- }
- bless { @_ }, $class;
-}
-
-#line 61
-
-sub AUTOLOAD {
- local $@;
- my $func = eval { shift->_top->autoload } or return;
- goto &$func;
-}
-
-#line 75
-
-sub _top {
- $_[0]->{_top};
-}
-
-#line 90
-
-sub admin {
- $_[0]->_top->{admin}
- or
- Module::Install::Base::FakeAdmin->new;
-}
-
-#line 106
-
-sub is_admin {
- $_[0]->admin->VERSION;
-}
-
-sub DESTROY {}
-
-package Module::Install::Base::FakeAdmin;
-
-my $fake;
-
-sub new {
- $fake ||= bless(\@_, $_[0]);
-}
-
-sub AUTOLOAD {}
-
-sub DESTROY {}
-
-# Restore warning handler
-BEGIN {
- $SIG{__WARN__} = $SIG{__WARN__}->();
-}
-
-1;
-
-#line 154
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
deleted file mode 100644
index c9f91d1..0000000
--- a/inc/Module/Install/Can.pm
+++ /dev/null
@@ -1,81 +0,0 @@
-#line 1
-package Module::Install::Can;
-
-use strict;
-use Config ();
-use File::Spec ();
-use ExtUtils::MakeMaker ();
-use Module::Install::Base ();
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '0.95';
- @ISA = 'Module::Install::Base';
- $ISCORE = 1;
-}
-
-# check if we can load some module
-### Upgrade this to not have to load the module if possible
-sub can_use {
- my ($self, $mod, $ver) = @_;
- $mod =~ s{::|\\}{/}g;
- $mod .= '.pm' unless $mod =~ /\.pm$/i;
-
- my $pkg = $mod;
- $pkg =~ s{/}{::}g;
- $pkg =~ s{\.pm$}{}i;
-
- local $@;
- eval { require $mod; $pkg->VERSION($ver || 0); 1 };
-}
-
-# check if we can run some command
-sub can_run {
- my ($self, $cmd) = @_;
-
- my $_cmd = $cmd;
- return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
-
- for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
- next if $dir eq '';
- my $abs = File::Spec->catfile($dir, $_[1]);
- return $abs if (-x $abs or $abs = MM->maybe_command($abs));
- }
-
- return;
-}
-
-# can we locate a (the) C compiler
-sub can_cc {
- my $self = shift;
- my @chunks = split(/ /, $Config::Config{cc}) or return;
-
- # $Config{cc} may contain args; try to find out the program part
- while (@chunks) {
- return $self->can_run("@chunks") || (pop(@chunks), next);
- }
-
- return;
-}
-
-# Fix Cygwin bug on maybe_command();
-if ( $^O eq 'cygwin' ) {
- require ExtUtils::MM_Cygwin;
- require ExtUtils::MM_Win32;
- if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
- *ExtUtils::MM_Cygwin::maybe_command = sub {
- my ($self, $file) = @_;
- if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
- ExtUtils::MM_Win32->maybe_command($file);
- } else {
- ExtUtils::MM_Unix->maybe_command($file);
- }
- }
- }
-}
-
-1;
-
-__END__
-
-#line 156
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
deleted file mode 100644
index c728bcd..0000000
--- a/inc/Module/Install/Fetch.pm
+++ /dev/null
@@ -1,93 +0,0 @@
-#line 1
-package Module::Install::Fetch;
-
-use strict;
-use Module::Install::Base ();
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '0.95';
- @ISA = 'Module::Install::Base';
- $ISCORE = 1;
-}
-
-sub get_file {
- my ($self, %args) = @_;
- my ($scheme, $host, $path, $file) =
- $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
-
- if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
- $args{url} = $args{ftp_url}
- or (warn("LWP support unavailable!\n"), return);
- ($scheme, $host, $path, $file) =
- $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
- }
-
- $|++;
- print "Fetching '$file' from $host... ";
-
- unless (eval { require Socket; Socket::inet_aton($host) }) {
- warn "'$host' resolve failed!\n";
- return;
- }
-
- return unless $scheme eq 'ftp' or $scheme eq 'http';
-
- require Cwd;
- my $dir = Cwd::getcwd();
- chdir $args{local_dir} or return if exists $args{local_dir};
-
- if (eval { require LWP::Simple; 1 }) {
- LWP::Simple::mirror($args{url}, $file);
- }
- elsif (eval { require Net::FTP; 1 }) { eval {
- # use Net::FTP to get past firewall
- my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
- $ftp->login("anonymous", 'anonymous at example.com');
- $ftp->cwd($path);
- $ftp->binary;
- $ftp->get($file) or (warn("$!\n"), return);
- $ftp->quit;
- } }
- elsif (my $ftp = $self->can_run('ftp')) { eval {
- # no Net::FTP, fallback to ftp.exe
- require FileHandle;
- my $fh = FileHandle->new;
-
- local $SIG{CHLD} = 'IGNORE';
- unless ($fh->open("|$ftp -n")) {
- warn "Couldn't open ftp: $!\n";
- chdir $dir; return;
- }
-
- my @dialog = split(/\n/, <<"END_FTP");
-open $host
-user anonymous anonymous\@example.com
-cd $path
-binary
-get $file $file
-quit
-END_FTP
- foreach (@dialog) { $fh->print("$_\n") }
- $fh->close;
- } }
- else {
- warn "No working 'ftp' program available!\n";
- chdir $dir; return;
- }
-
- unless (-f $file) {
- warn "Fetching failed: $@\n";
- chdir $dir; return;
- }
-
- return if exists $args{size} and -s $file != $args{size};
- system($args{run}) if exists $args{run};
- unlink($file) if $args{remove};
-
- print(((!exists $args{check_for} or -e $args{check_for})
- ? "done!" : "failed! ($!)"), "\n");
- chdir $dir; return !$?;
-}
-
-1;
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
deleted file mode 100644
index 431ec3f..0000000
--- a/inc/Module/Install/Makefile.pm
+++ /dev/null
@@ -1,405 +0,0 @@
-#line 1
-package Module::Install::Makefile;
-
-use strict 'vars';
-use ExtUtils::MakeMaker ();
-use Module::Install::Base ();
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '0.95';
- @ISA = 'Module::Install::Base';
- $ISCORE = 1;
-}
-
-sub Makefile { $_[0] }
-
-my %seen = ();
-
-sub prompt {
- shift;
-
- # Infinite loop protection
- my @c = caller();
- if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
- die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
- }
-
- # In automated testing or non-interactive session, always use defaults
- if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) {
- local $ENV{PERL_MM_USE_DEFAULT} = 1;
- goto &ExtUtils::MakeMaker::prompt;
- } else {
- goto &ExtUtils::MakeMaker::prompt;
- }
-}
-
-# Store a cleaned up version of the MakeMaker version,
-# since we need to behave differently in a variety of
-# ways based on the MM version.
-my $makemaker = eval $ExtUtils::MakeMaker::VERSION;
-
-# If we are passed a param, do a "newer than" comparison.
-# Otherwise, just return the MakeMaker version.
-sub makemaker {
- ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0
-}
-
-# Ripped from ExtUtils::MakeMaker 6.56, and slightly modified
-# as we only need to know here whether the attribute is an array
-# or a hash or something else (which may or may not be appendable).
-my %makemaker_argtype = (
- C => 'ARRAY',
- CONFIG => 'ARRAY',
-# CONFIGURE => 'CODE', # ignore
- DIR => 'ARRAY',
- DL_FUNCS => 'HASH',
- DL_VARS => 'ARRAY',
- EXCLUDE_EXT => 'ARRAY',
- EXE_FILES => 'ARRAY',
- FUNCLIST => 'ARRAY',
- H => 'ARRAY',
- IMPORTS => 'HASH',
- INCLUDE_EXT => 'ARRAY',
- LIBS => 'ARRAY', # ignore ''
- MAN1PODS => 'HASH',
- MAN3PODS => 'HASH',
- META_ADD => 'HASH',
- META_MERGE => 'HASH',
- PL_FILES => 'HASH',
- PM => 'HASH',
- PMLIBDIRS => 'ARRAY',
- PMLIBPARENTDIRS => 'ARRAY',
- PREREQ_PM => 'HASH',
- CONFIGURE_REQUIRES => 'HASH',
- SKIP => 'ARRAY',
- TYPEMAPS => 'ARRAY',
- XS => 'HASH',
-# VERSION => ['version',''], # ignore
-# _KEEP_AFTER_FLUSH => '',
-
- clean => 'HASH',
- depend => 'HASH',
- dist => 'HASH',
- dynamic_lib=> 'HASH',
- linkext => 'HASH',
- macro => 'HASH',
- postamble => 'HASH',
- realclean => 'HASH',
- test => 'HASH',
- tool_autosplit => 'HASH',
-
- # special cases where you can use makemaker_append
- CCFLAGS => 'APPENDABLE',
- DEFINE => 'APPENDABLE',
- INC => 'APPENDABLE',
- LDDLFLAGS => 'APPENDABLE',
- LDFROM => 'APPENDABLE',
-);
-
-sub makemaker_args {
- my ($self, %new_args) = @_;
- my $args = ( $self->{makemaker_args} ||= {} );
- foreach my $key (keys %new_args) {
- if ($makemaker_argtype{$key} eq 'ARRAY') {
- $args->{$key} = [] unless defined $args->{$key};
- unless (ref $args->{$key} eq 'ARRAY') {
- $args->{$key} = [$args->{$key}]
- }
- push @{$args->{$key}},
- ref $new_args{$key} eq 'ARRAY'
- ? @{$new_args{$key}}
- : $new_args{$key};
- }
- elsif ($makemaker_argtype{$key} eq 'HASH') {
- $args->{$key} = {} unless defined $args->{$key};
- foreach my $skey (keys %{ $new_args{$key} }) {
- $args->{$key}{$skey} = $new_args{$key}{$skey};
- }
- }
- elsif ($makemaker_argtype{$key} eq 'APPENDABLE') {
- $self->makemaker_append($key => $new_args{$key});
- }
- else {
- if (defined $args->{$key}) {
- warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n};
- }
- $args->{$key} = $new_args{$key};
- }
- }
- return $args;
-}
-
-# For mm args that take multiple space-seperated args,
-# append an argument to the current list.
-sub makemaker_append {
- my $self = shift;
- my $name = shift;
- my $args = $self->makemaker_args;
- $args->{$name} = defined $args->{$name}
- ? join( ' ', $args->{$name}, @_ )
- : join( ' ', @_ );
-}
-
-sub build_subdirs {
- my $self = shift;
- my $subdirs = $self->makemaker_args->{DIR} ||= [];
- for my $subdir (@_) {
- push @$subdirs, $subdir;
- }
-}
-
-sub clean_files {
- my $self = shift;
- my $clean = $self->makemaker_args->{clean} ||= {};
- %$clean = (
- %$clean,
- FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
- );
-}
-
-sub realclean_files {
- my $self = shift;
- my $realclean = $self->makemaker_args->{realclean} ||= {};
- %$realclean = (
- %$realclean,
- FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
- );
-}
-
-sub libs {
- my $self = shift;
- my $libs = ref $_[0] ? shift : [ shift ];
- $self->makemaker_args( LIBS => $libs );
-}
-
-sub inc {
- my $self = shift;
- $self->makemaker_args( INC => shift );
-}
-
-my %test_dir = ();
-
-sub _wanted_t {
- /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
-}
-
-sub tests_recursive {
- my $self = shift;
- if ( $self->tests ) {
- die "tests_recursive will not work if tests are already defined";
- }
- my $dir = shift || 't';
- unless ( -d $dir ) {
- die "tests_recursive dir '$dir' does not exist";
- }
- %test_dir = ();
- require File::Find;
- File::Find::find( \&_wanted_t, $dir );
- if ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
- File::Find::find( \&_wanted_t, 'xt' );
- }
- $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
-}
-
-sub write {
- my $self = shift;
- die "&Makefile->write() takes no arguments\n" if @_;
-
- # Check the current Perl version
- my $perl_version = $self->perl_version;
- if ( $perl_version ) {
- eval "use $perl_version; 1"
- or die "ERROR: perl: Version $] is installed, "
- . "but we need version >= $perl_version";
- }
-
- # Make sure we have a new enough MakeMaker
- require ExtUtils::MakeMaker;
-
- if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
- # MakeMaker can complain about module versions that include
- # an underscore, even though its own version may contain one!
- # Hence the funny regexp to get rid of it. See RT #35800
- # for details.
- my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/;
- $self->build_requires( 'ExtUtils::MakeMaker' => $v );
- $self->configure_requires( 'ExtUtils::MakeMaker' => $v );
- } else {
- # Allow legacy-compatibility with 5.005 by depending on the
- # most recent EU:MM that supported 5.005.
- $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
- $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
- }
-
- # Generate the MakeMaker params
- my $args = $self->makemaker_args;
- $args->{DISTNAME} = $self->name;
- $args->{NAME} = $self->module_name || $self->name;
- $args->{NAME} =~ s/-/::/g;
- $args->{VERSION} = $self->version or die <<'EOT';
-ERROR: Can't determine distribution version. Please specify it
-explicitly via 'version' in Makefile.PL, or set a valid $VERSION
-in a module, and provide its file path via 'version_from' (or
-'all_from' if you prefer) in Makefile.PL.
-EOT
-
- $DB::single = 1;
- if ( $self->tests ) {
- my @tests = split ' ', $self->tests;
- my %seen;
- $args->{test} = {
- TESTS => (join ' ', grep {!$seen{$_}++} @tests),
- };
- } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
- $args->{test} = {
- TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ),
- };
- }
- if ( $] >= 5.005 ) {
- $args->{ABSTRACT} = $self->abstract;
- $args->{AUTHOR} = join ', ', @{$self->author || []};
- }
- if ( $self->makemaker(6.10) ) {
- $args->{NO_META} = 1;
- #$args->{NO_MYMETA} = 1;
- }
- if ( $self->makemaker(6.17) and $self->sign ) {
- $args->{SIGN} = 1;
- }
- unless ( $self->is_admin ) {
- delete $args->{SIGN};
- }
- if ( $self->makemaker(6.31) and $self->license ) {
- $args->{LICENSE} = $self->license;
- }
-
- my $prereq = ($args->{PREREQ_PM} ||= {});
- %$prereq = ( %$prereq,
- map { @$_ } # flatten [module => version]
- map { @$_ }
- grep $_,
- ($self->requires)
- );
-
- # Remove any reference to perl, PREREQ_PM doesn't support it
- delete $args->{PREREQ_PM}->{perl};
-
- # Merge both kinds of requires into BUILD_REQUIRES
- my $build_prereq = ($args->{BUILD_REQUIRES} ||= {});
- %$build_prereq = ( %$build_prereq,
- map { @$_ } # flatten [module => version]
- map { @$_ }
- grep $_,
- ($self->configure_requires, $self->build_requires)
- );
-
- # Remove any reference to perl, BUILD_REQUIRES doesn't support it
- delete $args->{BUILD_REQUIRES}->{perl};
-
- # Delete bundled dists from prereq_pm
- my $subdirs = ($args->{DIR} ||= []);
- if ($self->bundles) {
- foreach my $bundle (@{ $self->bundles }) {
- my ($file, $dir) = @$bundle;
- push @$subdirs, $dir if -d $dir;
- delete $build_prereq->{$file}; #Delete from build prereqs only
- }
- }
-
- unless ( $self->makemaker('6.55_03') ) {
- %$prereq = (%$prereq,%$build_prereq);
- delete $args->{BUILD_REQUIRES};
- }
-
- if ( my $perl_version = $self->perl_version ) {
- eval "use $perl_version; 1"
- or die "ERROR: perl: Version $] is installed, "
- . "but we need version >= $perl_version";
-
- if ( $self->makemaker(6.48) ) {
- $args->{MIN_PERL_VERSION} = $perl_version;
- }
- }
-
- if ($self->installdirs) {
- warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS};
- $args->{INSTALLDIRS} = $self->installdirs;
- }
-
- my %args = map {
- ( $_ => $args->{$_} ) } grep {defined($args->{$_} )
- } keys %$args;
-
- my $user_preop = delete $args{dist}->{PREOP};
- if ( my $preop = $self->admin->preop($user_preop) ) {
- foreach my $key ( keys %$preop ) {
- $args{dist}->{$key} = $preop->{$key};
- }
- }
-
- my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
- $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
-}
-
-sub fix_up_makefile {
- my $self = shift;
- my $makefile_name = shift;
- my $top_class = ref($self->_top) || '';
- my $top_version = $self->_top->VERSION || '';
-
- my $preamble = $self->preamble
- ? "# Preamble by $top_class $top_version\n"
- . $self->preamble
- : '';
- my $postamble = "# Postamble by $top_class $top_version\n"
- . ($self->postamble || '');
-
- local *MAKEFILE;
- open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
- my $makefile = do { local $/; <MAKEFILE> };
- close MAKEFILE or die $!;
-
- $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
- $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
- $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
- $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
- $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
-
- # Module::Install will never be used to build the Core Perl
- # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
- # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
- $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
- #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
-
- # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
- $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g;
-
- # XXX - This is currently unused; not sure if it breaks other MM-users
- # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
-
- open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
- print MAKEFILE "$preamble$makefile$postamble" or die $!;
- close MAKEFILE or die $!;
-
- 1;
-}
-
-sub preamble {
- my ($self, $text) = @_;
- $self->{preamble} = $text . $self->{preamble} if defined $text;
- $self->{preamble};
-}
-
-sub postamble {
- my ($self, $text) = @_;
- $self->{postamble} ||= $self->admin->postamble;
- $self->{postamble} .= $text if defined $text;
- $self->{postamble}
-}
-
-1;
-
-__END__
-
-#line 531
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
deleted file mode 100644
index 162bde0..0000000
--- a/inc/Module/Install/Metadata.pm
+++ /dev/null
@@ -1,694 +0,0 @@
-#line 1
-package Module::Install::Metadata;
-
-use strict 'vars';
-use Module::Install::Base ();
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '0.95';
- @ISA = 'Module::Install::Base';
- $ISCORE = 1;
-}
-
-my @boolean_keys = qw{
- sign
-};
-
-my @scalar_keys = qw{
- name
- module_name
- abstract
- version
- distribution_type
- tests
- installdirs
-};
-
-my @tuple_keys = qw{
- configure_requires
- build_requires
- requires
- recommends
- bundles
- resources
-};
-
-my @resource_keys = qw{
- homepage
- bugtracker
- repository
-};
-
-my @array_keys = qw{
- keywords
- author
-};
-
-*authors = \&author;
-
-sub Meta { shift }
-sub Meta_BooleanKeys { @boolean_keys }
-sub Meta_ScalarKeys { @scalar_keys }
-sub Meta_TupleKeys { @tuple_keys }
-sub Meta_ResourceKeys { @resource_keys }
-sub Meta_ArrayKeys { @array_keys }
-
-foreach my $key ( @boolean_keys ) {
- *$key = sub {
- my $self = shift;
- if ( defined wantarray and not @_ ) {
- return $self->{values}->{$key};
- }
- $self->{values}->{$key} = ( @_ ? $_[0] : 1 );
- return $self;
- };
-}
-
-foreach my $key ( @scalar_keys ) {
- *$key = sub {
- my $self = shift;
- return $self->{values}->{$key} if defined wantarray and !@_;
- $self->{values}->{$key} = shift;
- return $self;
- };
-}
-
-foreach my $key ( @array_keys ) {
- *$key = sub {
- my $self = shift;
- return $self->{values}->{$key} if defined wantarray and !@_;
- $self->{values}->{$key} ||= [];
- push @{$self->{values}->{$key}}, @_;
- return $self;
- };
-}
-
-foreach my $key ( @resource_keys ) {
- *$key = sub {
- my $self = shift;
- unless ( @_ ) {
- return () unless $self->{values}->{resources};
- return map { $_->[1] }
- grep { $_->[0] eq $key }
- @{ $self->{values}->{resources} };
- }
- return $self->{values}->{resources}->{$key} unless @_;
- my $uri = shift or die(
- "Did not provide a value to $key()"
- );
- $self->resources( $key => $uri );
- return 1;
- };
-}
-
-foreach my $key ( grep { $_ ne "resources" } @tuple_keys) {
- *$key = sub {
- my $self = shift;
- return $self->{values}->{$key} unless @_;
- my @added;
- while ( @_ ) {
- my $module = shift or last;
- my $version = shift || 0;
- push @added, [ $module, $version ];
- }
- push @{ $self->{values}->{$key} }, @added;
- return map {@$_} @added;
- };
-}
-
-# Resource handling
-my %lc_resource = map { $_ => 1 } qw{
- homepage
- license
- bugtracker
- repository
-};
-
-sub resources {
- my $self = shift;
- while ( @_ ) {
- my $name = shift or last;
- my $value = shift or next;
- if ( $name eq lc $name and ! $lc_resource{$name} ) {
- die("Unsupported reserved lowercase resource '$name'");
- }
- $self->{values}->{resources} ||= [];
- push @{ $self->{values}->{resources} }, [ $name, $value ];
- }
- $self->{values}->{resources};
-}
-
-# Aliases for build_requires that will have alternative
-# meanings in some future version of META.yml.
-sub test_requires { shift->build_requires(@_) }
-sub install_requires { shift->build_requires(@_) }
-
-# Aliases for installdirs options
-sub install_as_core { $_[0]->installdirs('perl') }
-sub install_as_cpan { $_[0]->installdirs('site') }
-sub install_as_site { $_[0]->installdirs('site') }
-sub install_as_vendor { $_[0]->installdirs('vendor') }
-
-sub dynamic_config {
- my $self = shift;
- unless ( @_ ) {
- warn "You MUST provide an explicit true/false value to dynamic_config\n";
- return $self;
- }
- $self->{values}->{dynamic_config} = $_[0] ? 1 : 0;
- return 1;
-}
-
-sub perl_version {
- my $self = shift;
- return $self->{values}->{perl_version} unless @_;
- my $version = shift or die(
- "Did not provide a value to perl_version()"
- );
-
- # Normalize the version
- $version = $self->_perl_version($version);
-
- # We don't support the reall old versions
- unless ( $version >= 5.005 ) {
- die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
- }
-
- $self->{values}->{perl_version} = $version;
-}
-
-#Stolen from M::B
-my %license_urls = (
- perl => 'http://dev.perl.org/licenses/',
- apache => 'http://apache.org/licenses/LICENSE-2.0',
- artistic => 'http://opensource.org/licenses/artistic-license.php',
- artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
- lgpl => 'http://opensource.org/licenses/lgpl-license.php',
- lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
- lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
- bsd => 'http://opensource.org/licenses/bsd-license.php',
- gpl => 'http://opensource.org/licenses/gpl-license.php',
- gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
- gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
- mit => 'http://opensource.org/licenses/mit-license.php',
- mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
- open_source => undef,
- unrestricted => undef,
- restrictive => undef,
- unknown => undef,
-);
-
-sub license {
- my $self = shift;
- return $self->{values}->{license} unless @_;
- my $license = shift or die(
- 'Did not provide a value to license()'
- );
- $self->{values}->{license} = $license;
-
- # Automatically fill in license URLs
- if ( $license_urls{$license} ) {
- $self->resources( license => $license_urls{$license} );
- }
-
- return 1;
-}
-
-sub all_from {
- my ( $self, $file ) = @_;
-
- unless ( defined($file) ) {
- my $name = $self->name or die(
- "all_from called with no args without setting name() first"
- );
- $file = join('/', 'lib', split(/-/, $name)) . '.pm';
- $file =~ s{.*/}{} unless -e $file;
- unless ( -e $file ) {
- die("all_from cannot find $file from $name");
- }
- }
- unless ( -f $file ) {
- die("The path '$file' does not exist, or is not a file");
- }
-
- $self->{values}{all_from} = $file;
-
- # Some methods pull from POD instead of code.
- # If there is a matching .pod, use that instead
- my $pod = $file;
- $pod =~ s/\.pm$/.pod/i;
- $pod = $file unless -e $pod;
-
- # Pull the different values
- $self->name_from($file) unless $self->name;
- $self->version_from($file) unless $self->version;
- $self->perl_version_from($file) unless $self->perl_version;
- $self->author_from($pod) unless @{$self->author || []};
- $self->license_from($pod) unless $self->license;
- $self->abstract_from($pod) unless $self->abstract;
-
- return 1;
-}
-
-sub provides {
- my $self = shift;
- my $provides = ( $self->{values}->{provides} ||= {} );
- %$provides = (%$provides, @_) if @_;
- return $provides;
-}
-
-sub auto_provides {
- my $self = shift;
- return $self unless $self->is_admin;
- unless (-e 'MANIFEST') {
- warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
- return $self;
- }
- # Avoid spurious warnings as we are not checking manifest here.
- local $SIG{__WARN__} = sub {1};
- require ExtUtils::Manifest;
- local *ExtUtils::Manifest::manicheck = sub { return };
-
- require Module::Build;
- my $build = Module::Build->new(
- dist_name => $self->name,
- dist_version => $self->version,
- license => $self->license,
- );
- $self->provides( %{ $build->find_dist_packages || {} } );
-}
-
-sub feature {
- my $self = shift;
- my $name = shift;
- my $features = ( $self->{values}->{features} ||= [] );
- my $mods;
-
- if ( @_ == 1 and ref( $_[0] ) ) {
- # The user used ->feature like ->features by passing in the second
- # argument as a reference. Accomodate for that.
- $mods = $_[0];
- } else {
- $mods = \@_;
- }
-
- my $count = 0;
- push @$features, (
- $name => [
- map {
- ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
- } @$mods
- ]
- );
-
- return @$features;
-}
-
-sub features {
- my $self = shift;
- while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
- $self->feature( $name, @$mods );
- }
- return $self->{values}->{features}
- ? @{ $self->{values}->{features} }
- : ();
-}
-
-sub no_index {
- my $self = shift;
- my $type = shift;
- push @{ $self->{values}->{no_index}->{$type} }, @_ if $type;
- return $self->{values}->{no_index};
-}
-
-sub read {
- my $self = shift;
- $self->include_deps( 'YAML::Tiny', 0 );
-
- require YAML::Tiny;
- my $data = YAML::Tiny::LoadFile('META.yml');
-
- # Call methods explicitly in case user has already set some values.
- while ( my ( $key, $value ) = each %$data ) {
- next unless $self->can($key);
- if ( ref $value eq 'HASH' ) {
- while ( my ( $module, $version ) = each %$value ) {
- $self->can($key)->($self, $module => $version );
- }
- } else {
- $self->can($key)->($self, $value);
- }
- }
- return $self;
-}
-
-sub write {
- my $self = shift;
- return $self unless $self->is_admin;
- $self->admin->write_meta;
- return $self;
-}
-
-sub version_from {
- require ExtUtils::MM_Unix;
- my ( $self, $file ) = @_;
- $self->version( ExtUtils::MM_Unix->parse_version($file) );
-}
-
-sub abstract_from {
- require ExtUtils::MM_Unix;
- my ( $self, $file ) = @_;
- $self->abstract(
- bless(
- { DISTNAME => $self->name },
- 'ExtUtils::MM_Unix'
- )->parse_abstract($file)
- );
-}
-
-# Add both distribution and module name
-sub name_from {
- my ($self, $file) = @_;
- if (
- Module::Install::_read($file) =~ m/
- ^ \s*
- package \s*
- ([\w:]+)
- \s* ;
- /ixms
- ) {
- my ($name, $module_name) = ($1, $1);
- $name =~ s{::}{-}g;
- $self->name($name);
- unless ( $self->module_name ) {
- $self->module_name($module_name);
- }
- } else {
- die("Cannot determine name from $file\n");
- }
-}
-
-sub _extract_perl_version {
- if (
- $_[0] =~ m/
- ^\s*
- (?:use|require) \s*
- v?
- ([\d_\.]+)
- \s* ;
- /ixms
- ) {
- my $perl_version = $1;
- $perl_version =~ s{_}{}g;
- return $perl_version;
- } else {
- return;
- }
-}
-
-sub perl_version_from {
- my $self = shift;
- my $perl_version=_extract_perl_version(Module::Install::_read($_[0]));
- if ($perl_version) {
- $self->perl_version($perl_version);
- } else {
- warn "Cannot determine perl version info from $_[0]\n";
- return;
- }
-}
-
-sub author_from {
- my $self = shift;
- my $content = Module::Install::_read($_[0]);
- if ($content =~ m/
- =head \d \s+ (?:authors?)\b \s*
- ([^\n]*)
- |
- =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
- .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
- ([^\n]*)
- /ixms) {
- my $author = $1 || $2;
-
- # XXX: ugly but should work anyway...
- if (eval "require Pod::Escapes; 1") {
- # Pod::Escapes has a mapping table.
- # It's in core of perl >= 5.9.3, and should be installed
- # as one of the Pod::Simple's prereqs, which is a prereq
- # of Pod::Text 3.x (see also below).
- $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
- {
- defined $2
- ? chr($2)
- : defined $Pod::Escapes::Name2character_number{$1}
- ? chr($Pod::Escapes::Name2character_number{$1})
- : do {
- warn "Unknown escape: E<$1>";
- "E<$1>";
- };
- }gex;
- }
- elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) {
- # Pod::Text < 3.0 has yet another mapping table,
- # though the table name of 2.x and 1.x are different.
- # (1.x is in core of Perl < 5.6, 2.x is in core of
- # Perl < 5.9.3)
- my $mapping = ($Pod::Text::VERSION < 2)
- ? \%Pod::Text::HTML_Escapes
- : \%Pod::Text::ESCAPES;
- $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
- {
- defined $2
- ? chr($2)
- : defined $mapping->{$1}
- ? $mapping->{$1}
- : do {
- warn "Unknown escape: E<$1>";
- "E<$1>";
- };
- }gex;
- }
- else {
- $author =~ s{E<lt>}{<}g;
- $author =~ s{E<gt>}{>}g;
- }
- $self->author($author);
- } else {
- warn "Cannot determine author info from $_[0]\n";
- }
-}
-
-sub _extract_license {
- my $pod = shift;
- my $matched;
- return __extract_license(
- ($matched) = $pod =~ m/
- (=head \d \s+ (?:licen[cs]e|licensing)\b.*?)
- (=head \d.*|=cut.*|)\z
- /ixms
- ) || __extract_license(
- ($matched) = $pod =~ m/
- (=head \d \s+ (?:copyrights?|legal)\b.*?)
- (=head \d.*|=cut.*|)\z
- /ixms
- );
-}
-
-sub __extract_license {
- my $license_text = shift or return;
- my @phrases = (
- 'under the same (?:terms|license) as (?:perl|the perl programming language)' => 'perl', 1,
- 'under the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
- 'Artistic and GPL' => 'perl', 1,
- 'GNU general public license' => 'gpl', 1,
- 'GNU public license' => 'gpl', 1,
- 'GNU lesser general public license' => 'lgpl', 1,
- 'GNU lesser public license' => 'lgpl', 1,
- 'GNU library general public license' => 'lgpl', 1,
- 'GNU library public license' => 'lgpl', 1,
- 'BSD license' => 'bsd', 1,
- 'Artistic license' => 'artistic', 1,
- 'GPL' => 'gpl', 1,
- 'LGPL' => 'lgpl', 1,
- 'BSD' => 'bsd', 1,
- 'Artistic' => 'artistic', 1,
- 'MIT' => 'mit', 1,
- 'proprietary' => 'proprietary', 0,
- );
- while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
- $pattern =~ s#\s+#\\s+#gs;
- if ( $license_text =~ /\b$pattern\b/i ) {
- return $license;
- }
- }
-}
-
-sub license_from {
- my $self = shift;
- if (my $license=_extract_license(Module::Install::_read($_[0]))) {
- $self->license($license);
- } else {
- warn "Cannot determine license info from $_[0]\n";
- return 'unknown';
- }
-}
-
-sub _extract_bugtracker {
- my @links = $_[0] =~ m#L<(
- \Qhttp://rt.cpan.org/\E[^>]+|
- \Qhttp://github.com/\E[\w_]+/[\w_]+/issues|
- \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list
- )>#gx;
- my %links;
- @links{@links}=();
- @links=keys %links;
- return @links;
-}
-
-sub bugtracker_from {
- my $self = shift;
- my $content = Module::Install::_read($_[0]);
- my @links = _extract_bugtracker($content);
- unless ( @links ) {
- warn "Cannot determine bugtracker info from $_[0]\n";
- return 0;
- }
- if ( @links > 1 ) {
- warn "Found more than one bugtracker link in $_[0]\n";
- return 0;
- }
-
- # Set the bugtracker
- bugtracker( $links[0] );
- return 1;
-}
-
-sub requires_from {
- my $self = shift;
- my $content = Module::Install::_readperl($_[0]);
- my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
- while ( @requires ) {
- my $module = shift @requires;
- my $version = shift @requires;
- $self->requires( $module => $version );
- }
-}
-
-sub test_requires_from {
- my $self = shift;
- my $content = Module::Install::_readperl($_[0]);
- my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
- while ( @requires ) {
- my $module = shift @requires;
- my $version = shift @requires;
- $self->test_requires( $module => $version );
- }
-}
-
-# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
-# numbers (eg, 5.006001 or 5.008009).
-# Also, convert double-part versions (eg, 5.8)
-sub _perl_version {
- my $v = $_[-1];
- $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
- $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
- $v =~ s/(\.\d\d\d)000$/$1/;
- $v =~ s/_.+$//;
- if ( ref($v) ) {
- # Numify
- $v = $v + 0;
- }
- return $v;
-}
-
-
-
-
-
-######################################################################
-# MYMETA Support
-
-sub WriteMyMeta {
- die "WriteMyMeta has been deprecated";
-}
-
-sub write_mymeta_yaml {
- my $self = shift;
-
- # We need YAML::Tiny to write the MYMETA.yml file
- unless ( eval { require YAML::Tiny; 1; } ) {
- return 1;
- }
-
- # Generate the data
- my $meta = $self->_write_mymeta_data or return 1;
-
- # Save as the MYMETA.yml file
- print "Writing MYMETA.yml\n";
- YAML::Tiny::DumpFile('MYMETA.yml', $meta);
-}
-
-sub write_mymeta_json {
- my $self = shift;
-
- # We need JSON to write the MYMETA.json file
- unless ( eval { require JSON; 1; } ) {
- return 1;
- }
-
- # Generate the data
- my $meta = $self->_write_mymeta_data or return 1;
-
- # Save as the MYMETA.yml file
- print "Writing MYMETA.json\n";
- Module::Install::_write(
- 'MYMETA.json',
- JSON->new->pretty(1)->canonical->encode($meta),
- );
-}
-
-sub _write_mymeta_data {
- my $self = shift;
-
- # If there's no existing META.yml there is nothing we can do
- return undef unless -f 'META.yml';
-
- # We need Parse::CPAN::Meta to load the file
- unless ( eval { require Parse::CPAN::Meta; 1; } ) {
- return undef;
- }
-
- # Merge the perl version into the dependencies
- my $val = $self->Meta->{values};
- my $perl = delete $val->{perl_version};
- if ( $perl ) {
- $val->{requires} ||= [];
- my $requires = $val->{requires};
-
- # Canonize to three-dot version after Perl 5.6
- if ( $perl >= 5.006 ) {
- $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e
- }
- unshift @$requires, [ perl => $perl ];
- }
-
- # Load the advisory META.yml file
- my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
- my $meta = $yaml[0];
-
- # Overwrite the non-configure dependency hashs
- delete $meta->{requires};
- delete $meta->{build_requires};
- delete $meta->{recommends};
- if ( exists $val->{requires} ) {
- $meta->{requires} = { map { @$_ } @{ $val->{requires} } };
- }
- if ( exists $val->{build_requires} ) {
- $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
- }
-
- return $meta;
-}
-
-1;
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
deleted file mode 100644
index f55e166..0000000
--- a/inc/Module/Install/Win32.pm
+++ /dev/null
@@ -1,64 +0,0 @@
-#line 1
-package Module::Install::Win32;
-
-use strict;
-use Module::Install::Base ();
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '0.95';
- @ISA = 'Module::Install::Base';
- $ISCORE = 1;
-}
-
-# determine if the user needs nmake, and download it if needed
-sub check_nmake {
- my $self = shift;
- $self->load('can_run');
- $self->load('get_file');
-
- require Config;
- return unless (
- $^O eq 'MSWin32' and
- $Config::Config{make} and
- $Config::Config{make} =~ /^nmake\b/i and
- ! $self->can_run('nmake')
- );
-
- print "The required 'nmake' executable not found, fetching it...\n";
-
- require File::Basename;
- my $rv = $self->get_file(
- url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
- ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
- local_dir => File::Basename::dirname($^X),
- size => 51928,
- run => 'Nmake15.exe /o > nul',
- check_for => 'Nmake.exe',
- remove => 1,
- );
-
- die <<'END_MESSAGE' unless $rv;
-
--------------------------------------------------------------------------------
-
-Since you are using Microsoft Windows, you will need the 'nmake' utility
-before installation. It's available at:
-
- http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe
- or
- ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe
-
-Please download the file manually, save it to a directory in %PATH% (e.g.
-C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to
-that directory, and run "Nmake15.exe" from there; that will create the
-'nmake.exe' file needed by this module.
-
-You may then resume the installation process described in README.
-
--------------------------------------------------------------------------------
-END_MESSAGE
-
-}
-
-1;
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
deleted file mode 100644
index 6b3bba7..0000000
--- a/inc/Module/Install/WriteAll.pm
+++ /dev/null
@@ -1,63 +0,0 @@
-#line 1
-package Module::Install::WriteAll;
-
-use strict;
-use Module::Install::Base ();
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '0.95';;
- @ISA = qw{Module::Install::Base};
- $ISCORE = 1;
-}
-
-sub WriteAll {
- my $self = shift;
- my %args = (
- meta => 1,
- sign => 0,
- inline => 0,
- check_nmake => 1,
- @_,
- );
-
- $self->sign(1) if $args{sign};
- $self->admin->WriteAll(%args) if $self->is_admin;
-
- $self->check_nmake if $args{check_nmake};
- unless ( $self->makemaker_args->{PL_FILES} ) {
- # XXX: This still may be a bit over-defensive...
- unless ($self->makemaker(6.25)) {
- $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL';
- }
- }
-
- # Until ExtUtils::MakeMaker support MYMETA.yml, make sure
- # we clean it up properly ourself.
- $self->realclean_files('MYMETA.yml');
-
- if ( $args{inline} ) {
- $self->Inline->write;
- } else {
- $self->Makefile->write;
- }
-
- # The Makefile write process adds a couple of dependencies,
- # so write the META.yml files after the Makefile.
- if ( $args{meta} ) {
- $self->Meta->write;
- }
-
- # Experimental support for MYMETA
- if ( $ENV{X_MYMETA} ) {
- if ( $ENV{X_MYMETA} eq 'JSON' ) {
- $self->Meta->write_mymeta_json;
- } else {
- $self->Meta->write_mymeta_yaml;
- }
- }
-
- return 1;
-}
-
-1;
commit 535d874de98632cdd6bcee53216672f6013c37bd
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Sun Mar 20 23:26:52 2011 -0400
Force utf8 mode on test output, to avoid "Wide character in print" during tests
diff --git a/t/lib/Net/IMAP/Server/Test.pm b/t/lib/Net/IMAP/Server/Test.pm
index fa96ca2..c5087a2 100644
--- a/t/lib/Net/IMAP/Server/Test.pm
+++ b/t/lib/Net/IMAP/Server/Test.pm
@@ -13,6 +13,7 @@ sub SSL_PORT() { 2001 + $PPID*2 }
sub import_extra {
my $class = shift;
Test::More->export_to_level(2);
+ binmode $class->builder->output, ":utf8";
}
my $pid;
commit e9c1facc8497a3b34331f3d056f711780c72bb71
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Sun Mar 20 23:30:52 2011 -0400
Connect a little more aggessively when waiting for the server to start
diff --git a/t/lib/Net/IMAP/Server/Test.pm b/t/lib/Net/IMAP/Server/Test.pm
index c5087a2..5725b48 100644
--- a/t/lib/Net/IMAP/Server/Test.pm
+++ b/t/lib/Net/IMAP/Server/Test.pm
@@ -5,6 +5,7 @@ use strict;
use warnings;
use IO::Socket::SSL;
+use Time::HiRes qw();
my $PPID = $$;
sub PORT() { 2000 + $PPID*2 }
@@ -65,10 +66,11 @@ sub connect {
@_
);
my $socketclass = delete $args{Class};
- for (1..10) {
+ my $start = Time::HiRes::time();
+ while (Time::HiRes::time() - $start < 10) {
my $socket = $socketclass->new( %args );
return $class->builder->{$class->socket_key} = $socket if $socket;
- sleep 1;
+ Time::HiRes::sleep(0.1);
}
return;
}
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list