Bug#887536: dh-make-perl depends on libemail-address-perl

[Pali Rohár]

On Saturday 19 May 2018 15:28:14 gregor herrmann wrote:
> On Wed, 17 Jan 2018 20:50:05 +0100, Pali Rohár wrote:
> 
> > Hi! Package dh-make-perl depends on libemail-address-perl which is
> > vulnerable to CVE-2015-7686, see bug #868170. libemail-address-perl
> > provides perl module Email::Address which is now unmaintained. There is
> > a new perl module Email::Address::XS which is API compatible replacement
> > for Email::Address and is available in libemail-address-xs-perl. Please
> > port dh-make-perl package to use libemail-address-xs-perl. 
> 
> dh-make-perl uses
> 
> % grep -r Email::Address
> Build.PL:        'Email::Address'            => 0,
> lib/DhMakePerl/Command/Packaging.pm:use Email::Address;
> lib/DhMakePerl/Command/Packaging.pm:my $EMAIL_RE = $Email::Address::addr_spec;
> 
> And I think there is no ::addr_spec in libemail-address-xs-perl?

Yes, Email::Address::XS does not have these regexes defined.

> > If you need
> > help with porting let me know.
> > 
> Yes, please :)

I looked at that Packaging.pm file and I'm really not sure that it is
doing...

For me it looks like that $PERSON_PARSE_RE just extract phrase (display
name) from the email address. For this action simple ->parse() method
should be enough and then ->phrase() would return it.

$EMAIL_CHANGES_RE seems to extract list of pairs <name, bare_address>
which matches some specific format. So the only thing needed here is to
check if _address_ is really email address without phrase and angle
brackets. For parsing ->parse_bare_address() method can be used and then
check ->address() that returned something.

I created patch with these changes, but I'm not sure if it is correct
due to fact that I do not know what that code should do. So it would be
needed to properly test these changes.

Anyway, do you really need to parse email address according to RFC2822?
And is not (.*) in these cases enough?

Here is patch:

diff --git a/Build.PL b/Build.PL
index eb88fa8..a54fc0f 100644
--- a/Build.PL
+++ b/Build.PL
@@ -25,7 +25,7 @@ my $builder = My::Builder->new(
         'Cwd'                       => 0,
         'Dpkg'                      => 0,
         'Dpkg::Source::Package'     => '1.01',
-        'Email::Address'            => 0,
+        'Email::Address::XS'        => '1.01',
         'Email::Date::Format'       => 0,
         'File::Basename'            => 0,
         'File::Copy'                => 0,
diff --git a/lib/DhMakePerl/Command/Packaging.pm b/lib/DhMakePerl/Command/Packaging.pm
index 8f14caa..9fb9a9e 100644
--- a/lib/DhMakePerl/Command/Packaging.pm
+++ b/lib/DhMakePerl/Command/Packaging.pm
@@ -35,6 +35,7 @@ use Debian::Control::FromCPAN;
 use Debian::Dependencies;
 use Debian::Rules;
 use DhMakePerl::PodParser ();
+use Email::Address::XS 1.01;
 use File::Basename qw(basename dirname);
 use File::Find qw(find);
 use File::Path ();
@@ -1210,31 +1211,6 @@ sub upsurl {
 }
 
 
-my $ACTUAL_NAME_RE = '\pL[\s\pL\-\'\.]*\pL';
-
-# See http://www.faqs.org/rfcs/rfc2822.html
-# Section 3.4.1
-use Email::Address;
-my $EMAIL_RE = $Email::Address::addr_spec;
-
-my $EMAIL_CHANGES_RE = qr{
-    ^                           # beginining of line
-    \s+\*\s                     # item marker
-    Email\schange:\s            # email change token
-    ($ACTUAL_NAME_RE)           # actual name
-    \s+->\s+                    # gap between name and email
-    ($EMAIL_RE)                 # email address
-    $                           # end of line
-}xms;
-
-my $PERSON_PARSE_RE = qr{
-    \A                          # beginining of string
-    ($ACTUAL_NAME_RE)           # actual name
-    \s                          # gap
-    \<$EMAIL_RE\>               # logged email
-    \z                          # end of string
-}xms;
-
 # This is what needs fixing.
 sub copyright_from_changelog {
     my ( $self, $firstmaint, $firstyear ) = @_;
@@ -1248,17 +1224,23 @@ sub copyright_from_changelog {
         my $date        = $_->Date;
         my @date_pieces = split( " ", $date );
         my $year        = $date_pieces[3];
-        if (my %changes = ($_->Changes =~ m/$EMAIL_CHANGES_RE/xmsg)) {
+        if (my %changes = ($_->Changes =~ m/^\s+\*\sEmail\schange:\s+(.*?)\s+->\s+(.*?)\s*$/xmsg)) {
             # This way round since we are going backward in time thru changelog
             foreach my $p (keys %changes) {
-                $changes{$p} =~ s{[\s\n]+$}{}xms;
+                # Parse bare email address; undef if it not an email address
+                my $address = Email::Address::XS->parse_bare_address($changes{$p})->address();
+                if ($address) {
+                    $changes{$p} = $address;
+                } else {
+                    delete $changes{$p};
+                }
             }
             %email_changes = (
                 %changes,
                 %email_changes
             );
         }
-        if (my ($name) = ($person =~ $PERSON_PARSE_RE)) {
+        if (my $name = Email::Address::XS->parse($person)->phrase()) {
             if (exists $email_changes{$name}) {
                 $person = "$name <$email_changes{$name}>";
             }


-- 
Pali Rohár
pali.rohar at gmail.com
-------------- next part --------------
A non-text attachment was scrubbed...
Name: signature.asc
Type: application/pgp-signature
Size: 195 bytes
Desc: not available
URL: <http://alioth-lists.debian.net/pipermail/pkg-perl-maintainers/attachments/20180519/8d042e22/attachment.sig>