[merged]
authorHeiko Schlittermann (JUMPER) <hs@schlittermann.de>
Wed, 04 Jan 2012 14:15:39 +0100
changeset 17 e65ad1481966
parent 16 3996e5b8789f (diff)
parent 14 4f50e6aa028b (current diff)
child 18 4ba3303aae86
[merged]
scratch/sign
--- 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");
+