Bug#523515: libarchive-ar-perl: wrong permissions on files in ar archive - module writes wrong ar header

[Stephen Gran]

This one time, at band camp, Stephen Gran said:
> Simple minded patch below.
> 
> --- /usr/share/perl5/Archive/Ar.pm      2009-04-10 19:57:39.000000000 +0100
> +++ Ar.pm       2009-04-10 19:58:05.000000000 +0100
> @@ -173,7 +173,7 @@
>                         "date" => $mtime,
>                         "uid"  => $uid,
>                         "gid"  => $gid, 
> -                       "mode" => $mode,
> +                       "mode" => sprintf("%o",$mode),
>                         "size" => $size,
>                 };

As it turns out, simple wasn't correct.  We need to cast it going in and
out in all code paths.  Better patch below:

--- /usr/share/perl5/Archive/Ar.pm      2009-04-10 19:57:39.000000000 +0100
+++ lib/Archive/Ar.pm   2009-04-11 14:49:19.000000000 +0100
@@ -219,7 +219,7 @@
        $params->{uid} ||= 0;
        $params->{gid} ||= 0;
        $params->{date} ||= timelocal(localtime());
-       $params->{mode} ||= "100644";
+       $params->{mode} ||= "33188";
        
        unless($this->_addFile($params))
        {
@@ -252,7 +252,13 @@
 
                $content->{uid} ||= "";
                $content->{gid} ||= "";
-               $outstr.= pack("A16A12A6A6A8A10", @$content{qw/name date uid gid mode size/});
+               $outstr.= pack("A16A12A6A6A8A10", (
+                               $content->{name},
+                               $content->{date},
+                               $content->{uid},
+                               $content->{gid}, 
+                               sprintf ("%o", $content->{mode}),
+                               $content->{size}));
                $outstr.= ARFMAG;
                $outstr.= $content->{data};
                unless (((length($content->{data})) % 2) == 0) {
@@ -333,6 +339,7 @@
                                $fields[$_] =~ s/\s*$//g;
                        }
 
+                       $fields[4] = oct($fields[4]);
                        my $headers = {};
                        @$headers{qw/name date uid gid mode size/} = @fields;

-- 
 -----------------------------------------------------------------
|   ,''`.                                            Stephen Gran |
|  : :' :                                        sgran at debian.org |
|  `. `'                        Debian user, admin, and developer |
|    `-                                     http://www.debian.org |
 -----------------------------------------------------------------
-------------- next part --------------
A non-text attachment was scrubbed...
Name: not available
Type: application/pgp-signature
Size: 189 bytes
Desc: Digital signature
URL: <http://lists.alioth.debian.org/pipermail/pkg-perl-maintainers/attachments/20090411/3374f7d4/attachment.pgp>