# HG changeset patch
# User Heiko Schlittermann (JUMPER) <hs@schlittermann.de>
# Date 1321006970 -3600
# Node ID 9f127fcfdf6d49e3d67ec70b83f4a4a40a27d76f
# Parent  15a5ac599b959293172813a97cde5dc15f12cd63
signes, but does not work yet.

diff -r 15a5ac599b95 -r 9f127fcfdf6d lib/Message/2822.pm
--- a/lib/Message/2822.pm	Thu Nov 10 16:18:38 2011 +0100
+++ b/lib/Message/2822.pm	Fri Nov 11 11:22:50 2011 +0100
@@ -26,30 +26,53 @@
       or die "Can't open $DATA{fn}{$self}: $!\n";
 
     local $/ = "";
-    $DATA{header}{$self}   = <$fh>;
+    chomp($DATA{header}{$self}   = <$fh>);
     $DATA{body_pos}{$self} = tell($fh);
 
     return $self;
 }
 
-sub __header_fields {
+sub header_fields {
+    my ($self, $pattern) = @_;
+    $pattern //= qr/\S+/;
+    return grep /$pattern/i => $DATA{header}{$self} =~ /^(\S+?[: ])/mg;
+}
+
+sub header_lines {
     my $self = shift;
-    my %h;
-    @h{ $DATA{header}{$self} =~ /^(\S+?[: ])/mg } = ();
-    return keys %h;
+    my $field = shift // qr/.*/;
+    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 header_content {
-    my $self  = shift;
-    my $field = shift;
+sub remove_header_lines {
+    my $self = shift;
+    my $pattern = shift // die "Need a pattern!";
+    $DATA{header}{$self} =~ s/^$pattern.*?(?=^\S|\Z)//imsg;
+}
 
-    ### assert: $field =~ /[: ]$/
+sub add_header_line {
+    my $self = shift;
+    my $_ = shift;
+    $_ .= "\n" unless /\n$/;
+    $DATA{header}{$self} .= $_;
+}
 
-    # FIXME: not sure if the space following the header field name
-    # is optional or required
-    return $DATA{header}{$self} =~ /^$field\s+(.*?)(?=^\S)/imsg;
+sub header_contents {
+    my $self  = shift;
+    my $field = shift // qr/.*/;
+
+    my @r = map { (split /[: ]/, $_, 2)[1] } $self->header_lines($field);
+    return @r if wantarray;
+
+    foreach (@r) { s/\s*?\n\s+/ /mg; }
+    return join "" => @r;
 }
 
+
 sub orig_header {
     my $self = shift;
     my $fh   = $DATA{fh}{$self};
@@ -105,10 +128,28 @@
 The construcor. The file is opened r/o and read. The file will not be
 closed until the object disappears.
 
-=item @list = B<header_content>(I<field>)
+=item @list = 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>])
 
-Returns a list (*always* a list) with the contents of the specified
-header field. The I<field> has to include the colon ":" or space " ",
+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>])
+
+Returns the contents of the header lines matching the pattern. (default
+pattern: /.*/)
+
+In list context a list of B<unmodified> header lines is returned.
+In scalar context the header lines are de-wrapped and then returned,
+delimited by single linebreak.
+
+The I<field> has to include the colon ":" or space " ",
 since it is considered a part of the field name. I<field> is case
 insensitive!
 
diff -r 15a5ac599b95 -r 9f127fcfdf6d scratch/sign
--- a/scratch/sign	Thu Nov 10 16:18:38 2011 +0100
+++ b/scratch/sign	Fri Nov 11 11:22:50 2011 +0100
@@ -3,19 +3,57 @@
 use 5.010;
 use strict;
 use warnings;
+use File::Temp;
+use autodie qw(:all);
+
+use Digest::MD5 qw(md5_hex);
 
 use blib;
 use Message::2822;
 
-my $message = Message::2822->new(file => shift//"ex/mails/unsigned");
+umask(077);
+my $boundary = md5_hex(time);
+my $dir = File::Temp->newdir();
+
+my $unsigned = Message::2822->new(file => shift//"ex/mails/unsigned");
+
 
-say $message->header_content("received:");
-say $message->header_content("to:");
+# copy the body into a tmp file and copy there the content-
+# header lines
+open(my $message, "+>$dir/message");
+print {$message}
+    $unsigned->header_lines(qr/^content-/i), "\n",
+    $unsigned->orig_body;
+$message->flush();
+
+# 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\"");
+$unsigned->add_header_line("Content-Disposition: inline");
 
-exit;
+
+# ask GPG to sign it…
+system("gpg",
+    "--rfc1991",
+    "--detach-sign",
+    "--homedir" => "ex/gpg",
+    "--armor" => "$dir/message");
+
+open(my $sig, "$dir/message.asc");
+
+print $unsigned->header_lines, "\n";
 
-say $message->orig_header();
-say $message->orig_body();
+seek($message, 0, 0);
 
-#say map { ">> '$_'\n" } $message->header_fields();
+print "--${boundary}\n",
+      <$message>, "\n",
+      "--${boundary}\n",
+      <<___, <$sig>, "\n--${boundary}--\n";
+Content-Type: application/pgp-signature; name="signature.asc"
+Content-Description: Digital Signature
+Content-Disposition: inline
 
+___
diff -r 15a5ac599b95 -r 9f127fcfdf6d t/000-message.t
--- a/t/000-message.t	Thu Nov 10 16:18:38 2011 +0100
+++ b/t/000-message.t	Fri Nov 11 11:22:50 2011 +0100
@@ -17,11 +17,12 @@
 ok(scalar(@header_lines), "got some header lines");
 
 my $received = grep /^received:/i => @header_lines;
-my @received0 = $message->header_content("received:");
-my @received1 = $message->header_content("Received:");
+my @received0 = $message->header_contents("received:");
+my @received1 = $message->header_contents("Received:");
+my $received0 = $message->header_contents("received:");  # single lines
 
-is(scalar(@received0), $received, "$received received headers");
+is(scalar(@received0), $received, "$received received headers in list");
+is(scalar(@received0), scalar(my @a = $received0 =~ /\n/g), "$received received lines in scalar");
 is_deeply(\@received0, \@received1, "case insensitive field names");
 
-
 done_testing();