--- a/.hgignore Wed Jan 04 09:21:35 2012 +0100
+++ b/.hgignore Wed Jan 04 14:15:39 2012 +0100
@@ -3,3 +3,4 @@
_build
Build
blib
+cover_db
--- a/Build.PL Wed Jan 04 09:21:35 2012 +0100
+++ b/Build.PL Wed Jan 04 14:15:39 2012 +0100
@@ -10,5 +10,7 @@
},
build_requires => {
"Test::More" => "0.92",
+ "Test::Pod::Coverage" => "1.08",
+ "Pod::Coverage" => "0",
},
)->create_build_script();
--- a/ex/mails/unsigned Wed Jan 04 09:21:35 2012 +0100
+++ b/ex/mails/unsigned Wed Jan 04 14:15:39 2012 +0100
@@ -19,7 +19,6 @@
Organization: schlittermann -- internet & unix support
X-Phone: +49.172.7909055 / SMS welcome
User-Agent: Mutt/1.5.20 (2009-06-14)
-Content-Length: 50
Content-Type: text/plain;
charset=utf-8
--- a/lib/Message/2822.pm Wed Jan 04 09:21:35 2012 +0100
+++ b/lib/Message/2822.pm Wed Jan 04 14:15:39 2012 +0100
@@ -26,7 +26,7 @@
or die "Can't open $DATA{fn}{$self}: $!\n";
local $/ = "";
- chomp($DATA{header}{$self} = <$fh>);
+ chomp($DATA{header}{$self} = <$fh>);
$DATA{body_pos}{$self} = tell($fh);
return $self;
@@ -41,28 +41,30 @@
sub header_lines {
my $self = shift;
my $field = shift // qr/.*/;
- my @r = grep /$field/i => $DATA{header}{$self} =~ /(^\S+?[: ]\s*.*?\n)(?=^\S|\Z)/imsg;
+ my @r =
+ grep /$field/i => $DATA{header}{$self} =~
+ /(^\S+?[: ]\s*.*?\n)(?=^\S|\Z)/imsg;
return @r if wantarray;
foreach (@r) { s/\s*?\n\s+/ /mg; }
return join "" => @r;
}
-sub remove_header_lines {
- my $self = shift;
- my $pattern = shift // die "Need a pattern!";
- $DATA{header}{$self} =~ s/^$pattern.*?(?=^\S|\Z)//imsg;
-}
+#sub remove_header_lines {
+# my $self = shift;
+# my $pattern = shift // die "Need a pattern!";
+# $DATA{header}{$self} =~ s/^$pattern.*?(?=^\S|\Z)//imsg;
+#}
-sub add_header_line {
- my $self = shift;
- my $_ = shift;
- $_ .= "\n" unless /\n$/;
- $DATA{header}{$self} .= $_;
-}
+#sub add_header_line {
+#my $self = shift;
+#my $_ = shift;
+#$_ .= "\n" unless /\n$/;
+#$DATA{header}{$self} .= $_;
+#}
sub header_contents {
- my $self = shift;
+ my $self = shift;
my $field = shift // qr/.*/;
my @r = map { (split /[: ]/, $_, 2)[1] } $self->header_lines($field);
@@ -72,7 +74,6 @@
return join "" => @r;
}
-
sub orig_header {
my $self = shift;
my $fh = $DATA{fh}{$self};
@@ -121,6 +122,11 @@
=head1 METHODS
+B<Note:> Whenever we mention a I<pattern>, you may pass the pattern
+as "qr/pattern/", giving you any freedom in choosing modifiers and so on, or
+you may pass the pattern simply as a string "pattern", this well then
+silently converted to "qr/pattern/i".
+
=over
=item B<new>(file => I<file>)
@@ -128,19 +134,19 @@
The construcor. The file is opened r/o and read. The file will not be
closed until the object disappears.
-=item @list = B<header_fields>([I<pattern>])
+=item B<header_fields>([I<pattern>])
Return a list of existing header fields, matching the pattern.
See B<header_contents()> for information about the
returned format. (default pattern: /.*/)
-=item @list = B<header_lines>([I<pattern>])
+=item B<header_lines>([I<pattern>])
Returns the header line matching the I<pattern>. See B<header_contents()>
about the returned format. (default pattern: /.*/)
-=item @list = B<header_contents>([I<pattern>])
+=item B<header_contents>([I<pattern>])
Returns the contents of the header lines matching the pattern. (default
pattern: /.*/)
@@ -153,13 +159,13 @@
since it is considered a part of the field name. I<field> is case
insensitive!
-=item $scalar = $B<orig_header>()
+=item B<orig_header>()
-Returns the original header as it is.
+Returns the original header as it is in a single scalar.
-=item $body = B<orig_body>()
+=item B<orig_body>()
-Returns the original body as it is.
+Returns the original body as it is in a single scalar.
=back
--- a/scratch/sign Wed Jan 04 09:21:35 2012 +0100
+++ b/scratch/sign Wed Jan 04 14:15:39 2012 +0100
@@ -4,7 +4,6 @@
use strict;
use warnings;
use File::Temp;
-use GnuPG;
use autodie qw(:all);
use Digest::MD5 qw(md5_hex);
@@ -14,71 +13,45 @@
umask(077);
my $boundary = md5_hex(time);
-my $dir = File::Temp->newdir();
-
-my $unsigned = Message::2822->new(file => shift // "ex/mails/unsigned");
-
-# copy the changed body into a tmp file and copy there the
-# changed content-header lines
-open(my $message, "+>$dir/message");
+my $dir = File::Temp->newdir();
-open(my $header, "+>$dir/header");
-print {$header} $unsigned->header_lines(qr/^content-/i);
-seek($header, 0, 0);
-while (<$header>) {
- s/\r?\n/\r\n/g;
- print {$message} $_;
-}
-print {$message} "\r\n";
+my $unsigned = Message::2822->new(file => shift//"ex/mails/unsigned");
+
+die join " ", $unsigned->header_contents("Subject");
-open(my $body, "+>$dir/body");
-print {$body} $unsigned->orig_body;
-seek($body, 0, 0);
-while (<$body>) {
- s/\r?\n/\r\n/g;
- print {$message} $_;
-}
-
+# copy the body into a tmp file and copy there the content-
+# header lines
+open(my $message, "+>$dir/message");
+print {$message}
+ $unsigned->header_lines("content-"), "\n",
+ $unsigned->orig_body;
$message->flush();
-# ask GPG to sign it…
-open(my $sig, "+>$dir/signature.asc");
-my $gpg = new GnuPG(homedir => "ex/gpg");
-seek($message, 0, 0);
-eval {
- $gpg->sign(
- plaintext => $message,
- 'detach-sign' => 1,
- armor => 1,
- output => $sig
- );
-};
-
-if ($@) {
- $unsigned->add_header_line("X-GPGate-signed: not\n");
- print $unsigned->header_lines, "\n";
- print $unsigned->orig_body;
- exit 0;
-}
-
# now remove the unwanted content- header lines and add new ones
$unsigned->remove_header_lines(qr/^content-.*?:/im);
$unsigned->add_header_line("Content-Type: "
- . "multipart/signed; micalg=pgp-sha1;\n"
- . "\tprotocol=\"application/pgp-signature\"; boundary=\"$boundary\"");
+ . "multipart/signed; micalg=pgp-sha1;\n"
+ . "\tprotocol=\"application/pgp-signature\"; boundary=\"$boundary\"");
$unsigned->add_header_line("Content-Disposition: inline");
-$unsigned->add_header_line("X-GPGate-signed: yes\n");
+
+# ask GPG to sign it…
+system("gpg",
+ "--detach-sign",
+ "--homedir" => "ex/gpg",
+ "--armor" => "$dir/message");
+
+open(my $sig, "$dir/message.asc");
+
print $unsigned->header_lines, "\n";
seek($message, 0, 0);
-seek($sig, 0, 0);
print "--${boundary}\n",
- <$message>, "\n",
- "--${boundary}\n",
- <<___, <$sig>, "--${boundary}--\n";
+ <$message>,
+ "--${boundary}\n",
+ <<___, <$sig>, "\n--${boundary}--\n";
Content-Type: application/pgp-signature; name="signature.asc"
Content-Description: Digital Signature
Content-Disposition: inline
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/t/.perltidyrc Wed Jan 04 14:15:39 2012 +0100
@@ -0,0 +1,2 @@
+--paren-tightness=2
+--square-bracket-tightness=2
--- a/t/000-message.t Wed Jan 04 09:21:35 2012 +0100
+++ b/t/000-message.t Wed Jan 04 14:15:39 2012 +0100
@@ -3,9 +3,46 @@
use Test::More;
use_ok "Message::2822"
- or BAIL_OUT "Can't load the Message::2822 module";
+ or BAIL_OUT "Can't load the Message::2822 module";
+
+my @files = glob("ex/mails/*");
+cmp_ok(@files, ">", 1, "more then 1 test message");
+can_ok("Message::2822", qw(new));
+
+my %message;
+foreach my $file (@files) {
+ my $msg = Message::2822->new(file => $file);
+ isa_ok($msg, "Message::2822", "object is Message::2822 ($file)");
+ $message{$file} = $msg;
+}
+
+# check if we really get all header fields
+foreach my $file (keys %message) {
-my $file = "ex/mails/unsigned";
+ # get a sorted list of header fields
+ open(my $f, $file) or die "Can't open $file: $!\n";
+ $/ = "";
+ $_ = <$f>;
+ my @h = sort /^(\S+?[ :])/mg;
+
+ is_deeply([sort $message{$file}->header_fields()], \@h,
+ "all header fields");
+
+ is_deeply(
+ [sort $message{$file}->header_fields('^f')],
+ [grep /^f/i => @h],
+ "partial header fields '^f'"
+ );
+
+ is_deeply(
+ [sort $message{$file}->header_fields(qr/^f/i)],
+ [grep /^f/i => @h],
+ "partial header fields qr/^f/i"
+ );
+}
+
+done_testing;
+__END__
# the object itself
my $message = Message::2822->new(file => $file);
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/t/000-pod.t Wed Jan 04 14:15:39 2012 +0100
@@ -0,0 +1,15 @@
+use 5.010;
+use strict;
+use warnings;
+#use Pod::Coverage;
+use Test::Pod::Coverage tests => 1;
+
+#my $pc = Pod::Coverage->new(package => "Message::2822");
+#is($pc->coverage => 1, "POD coverage") or $pc->naked
+# ? diag("Undocumented: ", join ", " => $pc->naked)
+# : diag($pc->why_unrated);
+#
+#done_testing();
+
+pod_coverage_ok("Message::2822");
+