# HG changeset patch # User Heiko Schlittermann (JUMPER) # Date 1325682939 -3600 # Node ID e65ad1481966348945cfd6d49b249d86385e858b # Parent 3996e5b8789f3e2a4267ffbcbf7741fc5eebbf1f# Parent 4f50e6aa028b0d7f3bd9cd128f74830951078a61 [merged] diff -r 4f50e6aa028b -r e65ad1481966 .hgignore --- 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 diff -r 4f50e6aa028b -r e65ad1481966 Build.PL --- 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(); diff -r 4f50e6aa028b -r e65ad1481966 ex/mails/unsigned --- 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 diff -r 4f50e6aa028b -r e65ad1481966 lib/Message/2822.pm --- 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 Whenever we mention a I, 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(file => I) @@ -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([I]) +=item B([I]) Return a list of existing header fields, matching the pattern. See B for information about the returned format. (default pattern: /.*/) -=item @list = B([I]) +=item B([I]) Returns the header line matching the I. See B about the returned format. (default pattern: /.*/) -=item @list = B([I]) +=item B([I]) 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 is case insensitive! -=item $scalar = $B() +=item B() -Returns the original header as it is. +Returns the original header as it is in a single scalar. -=item $body = B() +=item B() -Returns the original body as it is. +Returns the original body as it is in a single scalar. =back diff -r 4f50e6aa028b -r e65ad1481966 scratch/sign --- 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 diff -r 4f50e6aa028b -r e65ad1481966 t/.perltidyrc --- /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 diff -r 4f50e6aa028b -r e65ad1481966 t/000-message.t --- 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); diff -r 4f50e6aa028b -r e65ad1481966 t/000-pod.t --- /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"); +