signes, but does not work yet.
--- 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!
--- 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
+___
--- 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();