This file is indexed.

/usr/share/perl5/Archive/Ar.pm is in libarchive-ar-perl 2.02-1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
###########################################################
#    Archive::Ar - Pure perl module to handle ar achives
#    
#    Copyright 2003 - Jay Bonci <jaybonci@cpan.org>
#    Copyright 2014 - John Bazik <jbazik@cpan.org>
#    Licensed under the same terms as perl itself
#
###########################################################
package Archive::Ar;

use base qw(Exporter);
our @EXPORT_OK = qw(COMMON BSD GNU);

use strict;
use File::Spec;
use Time::Local;
use Carp qw(carp longmess);

use vars qw($VERSION);
$VERSION = '2.02';

use constant CAN_CHOWN => ($> == 0 and $^O ne 'MacOS' and $^O ne 'MSWin32');

use constant ARMAG => "!<arch>\n";
use constant SARMAG => length(ARMAG);
use constant ARFMAG => "`\n";
use constant AR_EFMT1 => "#1/";

use constant COMMON => 1;
use constant BSD => 2;
use constant GNU => 3;

my $has_io_string;
BEGIN {
    $has_io_string = eval {
        require IO::String;
        IO::String->import();
        1;
    } || 0;
}

sub new {
    my $class = shift;
    my $file = shift;
    my $opts = shift || 0;
    my $self = bless {}, $class;
    my $defopts = {
        chmod => 1,
        chown => 1,
        same_perms => ($> == 0) ? 1:0,
        symbols => undef,
    };
    $opts = {warn => $opts} unless ref $opts;

    $self->clear();
    $self->{opts} = {(%$defopts, %{$opts})};
    if ($file) {
        return unless $self->read($file);
    }
    return $self;
}

sub set_opt {
    my $self = shift;
    my $name = shift;
    my $val = shift;

    $self->{opts}->{$name} = $val;
}

sub get_opt {
    my $self = shift;
    my $name = shift;

    return $self->{opts}->{$name};
}

sub type {
    return shift->{type};
}

sub clear {
    my $self = shift;

    $self->{names} = [];
    $self->{files} = {};
    $self->{type} = undef;
}

sub read {
    my $self = shift;
    my $file = shift;

    my $fh = $self->_get_handle($file);
    local $/ = undef;
    my $data = <$fh>;
    close $fh;
        
    return $self->read_memory($data);
}

sub read_memory {
    my $self = shift;
    my $data = shift;

    $self->clear();
    return unless $self->_parse($data);
    return length($data);
}

sub contains_file {
    my $self = shift;
    my $filename = shift;

    return unless defined $filename;
    return exists $self->{files}->{$filename};
}

sub extract {
    my $self = shift;

    for my $filename (@_ ? @_ : @{$self->{names}}) {
        $self->extract_file($filename) or return;
    }
    return 1;
}

sub extract_file {
    my $self = shift;
    my $filename = shift;
    my $target = shift || $filename;

    my $meta = $self->{files}->{$filename};
    return $self->_error("$filename: not in archive") unless $meta;
    open my $fh, '>', $target or return $self->_error("$target: $!");
    binmode $fh;
    syswrite $fh, $meta->{data} or return $self->_error("$filename: $!");
    close $fh or return $self->_error("$filename: $!");
    if (CAN_CHOWN && $self->{opts}->{chown}) {
        chown $meta->{uid}, $meta->{gid}, $filename or
					return $self->_error("$filename: $!");
    }
    if ($self->{opts}->{chmod}) {
        my $mode = $meta->{mode};
        unless ($self->{opts}->{same_perms}) {
            $mode &= ~(oct(7000) | (umask | 0));
        }
        chmod $mode, $filename or return $self->_error("$filename: $!");
    }
    utime $meta->{date}, $meta->{date}, $filename or
					return $self->_error("$filename: $!");
    return 1;
}

sub rename {
    my $self = shift;
    my $filename = shift;
    my $target = shift;

    if ($self->{files}->{$filename}) {
        $self->{files}->{$target} = $self->{files}->{$filename};
        delete $self->{files}->{$filename};
        for (@{$self->{names}}) {
            if ($_ eq $filename) {
                $_ = $target;
                last;
            }
        }
    }
}

sub chmod {
    my $self = shift;
    my $filename = shift;
    my $mode = shift;	# octal string or numeric

    return unless $self->{files}->{$filename};
    $self->{files}->{$filename}->{mode} =
                                    $mode + 0 eq $mode ? $mode : oct($mode);
    return 1;
}

sub chown {
    my $self = shift;
    my $filename = shift;
    my $uid = shift;
    my $gid = shift;

    return unless $self->{files}->{$filename};
    $self->{files}->{$filename}->{uid} = $uid if $uid >= 0;
    $self->{files}->{$filename}->{gid} = $gid if defined $gid && $gid >= 0;
    return 1;
}

sub remove {
    my $self = shift;
    my $files = ref $_[0] ? shift : \@_;

    my $nfiles_orig = scalar @{$self->{names}};

    for my $file (@$files) {
        next unless $file;
        if (exists($self->{files}->{$file})) {
            delete $self->{files}->{$file};
        }
        else {
            $self->_error("$file: no such member")
        }
    }
    @{$self->{names}} = grep($self->{files}->{$_}, @{$self->{names}});

    return $nfiles_orig - scalar @{$self->{names}};
}

sub list_files {
    my $self = shift;

    return wantarray ? @{$self->{names}} : $self->{names};
}

sub add_files {
    my $self = shift;
    my $files = ref $_[0] ? shift : \@_;

    for my $path (@$files) {
        if (open my $fd, $path) {
            my @st = stat $fd or return $self->_error("$path: $!");
            local $/ = undef;
            binmode $fd;
            my $content = <$fd>;
            close $fd;

            my $filename = (File::Spec->splitpath($path))[2];

            $self->_add_data($filename, $content, @st[9,4,5,2,7]);
        }
        else {
            $self->_error("$path: $!");
        }
    }
    return scalar @{$self->{names}};
}

sub add_data {
    my $self = shift;
    my $path = shift;
    my $content = shift;
    my $params = shift || {};

    return $self->_error("No filename given") unless $path;

    my $filename = (File::Spec->splitpath($path))[2];

    $self->_add_data($filename, $content,
                     $params->{date} || timelocal(localtime()),
                     $params->{uid} || 0,
                     $params->{gid} || 0,
                     $params->{mode} || 0100644) or return;

    return $self->{files}->{$filename}->{size};
}

sub write {
    my $self = shift;
    my $filename = shift;
    my $opts = {(%{$self->{opts}}, %{shift || {}})};
    my $type = $opts->{type} || $self->{type} || COMMON;

    my @body = ( ARMAG );

    my %gnuindex;
    my @filenames = @{$self->{names}};
    if ($type eq GNU) {
        #
        # construct extended filename index, if needed
        #
        if (my @longs = grep(length($_) > 15, @filenames)) {
            my $ptr = 0;
            for my $long (@longs) {
                $gnuindex{$long} = $ptr;
                $ptr += length($long) + 2;
            }
            push @body, pack('A16A32A10A2', '//', '', $ptr, ARFMAG),
                        join("/\n", @longs, '');
            push @body, "\n" if $ptr % 2; # padding
        }
    }
    for my $fn (@filenames) {
        my $meta = $self->{files}->{$fn};
        my $mode = sprintf('%o', $meta->{mode});
        my $size = $meta->{size};
        my $name;

        if ($type eq GNU) {
            $fn = '' if defined $opts->{symbols} && $fn eq $opts->{symbols};
            $name = $fn . '/';
        }
        else {
            $name = $fn;
        }
        if (length($name) <= 16 || $type eq COMMON) {
            push @body, pack('A16A12A6A6A8A10A2', $name,
                              @$meta{qw/date uid gid/}, $mode, $size, ARFMAG);
        }
        elsif ($type eq GNU) {
            push @body, pack('A1A15A12A6A6A8A10A2', '/', $gnuindex{$fn},
                              @$meta{qw/date uid gid/}, $mode, $size, ARFMAG);
        }
        elsif ($type eq BSD) {
            $size += length($name);
            push @body, pack('A3A13A12A6A6A8A10A2', AR_EFMT1, length($name),
                              @$meta{qw/date uid gid/}, $mode, $size, ARFMAG),
                        $name;
        }
        else {
            return $self->_error("$type: unexpected ar type");
        }
        push @body, $meta->{data};
        push @body, "\n" if $size % 2; # padding
    }
    if ($filename) {
        my $fh = $self->_get_handle($filename, '>');
        print $fh @body;
        close $fh;
        my $len = 0;
        $len += length($_) for @body;
        return $len;
    }
    else {
        return join '', @body;
    }
}

sub get_content {
    my $self = shift;
    my ($filename) = @_;

    unless ($filename) {
        $self->_error("get_content can't continue without a filename");
        return;
    }

    unless (exists($self->{files}->{$filename})) {
        $self->_error(
                "get_content failed because there is not a file named $filename");
        return;
    }

    return $self->{files}->{$filename};
}

sub get_data {
    my $self = shift;
    my $filename = shift;

    return $self->_error("$filename: no such member")
			unless exists $self->{files}->{$filename};
    return $self->{files}->{$filename}->{data};
}

sub get_handle {
    my $self = shift;
    my $filename = shift;
    my $fh;

    return $self->_error("$filename: no such member")
			unless exists $self->{files}->{$filename};
    if ($has_io_string) {
        $fh = IO::String->new($self->{files}->{$filename}->{data});
    }
    else {
        my $data = $self->{files}->{$filename}->{data};
        open $fh, '<', \$data or return $self->_error("in-memory file: $!");
    }
    return $fh;
}

sub error {
    my $self = shift;

    return shift() ? $self->{longmess} : $self->{error};
}

#
# deprecated
#
sub DEBUG {
    my $self = shift;
    my $debug = shift;

    $self->{opts}->{warn} = 1 unless (defined($debug) and int($debug) == 0);
}

sub _parse {
    my $self = shift;
    my $data = shift;

    unless (substr($data, 0, SARMAG, '') eq ARMAG) {
        return $self->_error("Bad magic number - not an ar archive");
    }
    my $type;
    my $names;
    while ($data =~ /\S/) {
        my ($name, $date, $uid, $gid, $mode, $size, $magic) =
                    unpack('A16A12A6A6A8A10a2', substr($data, 0, 60, ''));
        unless ($magic eq "`\n") {
            return $self->_error("Bad file header");
        }
        if ($name =~ m|^/|) {
            $type = GNU;
            if ($name eq '//') {
                $names = substr($data, 0, $size, '');
                substr($data, 0, $size % 2, '');
                next;
            }
            elsif ($name eq '/') {
                $name = $self->{opts}->{symbols};
                unless (defined $name && $name) {
                    substr($data, 0, $size + $size % 2, '');
                    next;
                }
            }
            else {
                $name = substr($names, int(substr($name, 1)));
                $name =~ s/\n.*//;
                chop $name;
            }
        }
        elsif ($name =~ m|^#1/|) {
            $type = BSD;
            $name = substr($data, 0, int(substr($name, 3)), '');
            $size -= length($name);
        }
        else {
            if ($name =~ m|/$|) {
                $type ||= GNU;	# only gnu has trailing slashes
                chop $name;
            }
        }
        $uid = int($uid);
        $gid = int($gid);
        $mode = oct($mode);
        my $content = substr($data, 0, $size, '');
        substr($data, 0, $size % 2, '');

        $self->_add_data($name, $content, $date, $uid, $gid, $mode, $size);
    }
    $self->{type} = $type || COMMON;
    return scalar @{$self->{names}};
}

sub _add_data {
    my $self = shift;
    my $filename = shift;
    my $content = shift || '';
    my $date = shift;
    my $uid = shift;
    my $gid = shift;
    my $mode = shift;
    my $size = shift;

    if (exists($self->{files}->{$filename})) {
        return $self->_error("$filename: entry already exists");
    }
    $self->{files}->{$filename} = {
        name => $filename,
        date => defined $date ? $date : timelocal(localtime()),
        uid => defined $uid ? $uid : 0,
        gid => defined $gid ? $gid : 0,
        mode => defined $mode ? $mode : 0100644,
        size => defined $size ? $size : length($content),
        data => $content,
    };
    push @{$self->{names}}, $filename;
    return 1;
}

sub _get_handle {
    my $self = shift;
    my $file = shift;
    my $mode = shift || '<';

    if (ref $file) {
        return $file if eval{*$file{IO}} or $file->isa('IO::Handle');
        return $self->_error("Not a filehandle");
    }
    else {
        open my $fh, $mode, $file or return $self->_error("$file: $!");
        binmode $fh;
        return $fh;
    }
}

sub _error {
    my $self = shift;
    my $msg = shift;

    $self->{error} = $msg;
    $self->{longerror} = longmess($msg);
    if ($self->{opts}->{warn} > 1) {
        carp $self->{longerror};
    }
    elsif ($self->{opts}->{warn}) {
        carp $self->{error};
    }
    return;
}

1;

__END__

=head1 NAME

Archive::Ar - Interface for manipulating ar archives

=head1 SYNOPSIS

    use Archive::Ar;

    my $ar = Archive::Ar->new;

    $ar->read('./foo.ar');
    $ar->extract;

    $ar->add_files('./bar.tar.gz', 'bat.pl')
    $ar->add_data('newfile.txt','Some contents');

    $ar->chmod('file1', 0644);
    $ar->chown('file1', $uid, $gid);

    $ar->remove('file1', 'file2');

    my $filehash = $ar->get_content('bar.tar.gz');
    my $data = $ar->get_data('bar.tar.gz');
    my $handle = $ar->get_handle('bar.tar.gz');

    my @files = $ar->list_files();

    my $archive = $ar->write;
    my $size = $ar->write('outbound.ar');

    $ar->error();


=head1 DESCRIPTION

Archive::Ar is a pure-perl way to handle standard ar archives.  

This is useful if you have those types of archives on the system, but it 
is also useful because .deb packages for the Debian GNU/Linux distribution are 
ar archives. This is one building block in a future chain of modules to build, 
manipulate, extract, and test debian modules with no platform or architecture 
dependence.

You may notice that the API to Archive::Ar is similar to Archive::Tar, and
this was done intentionally to keep similarity between the Archive::*
modules.

=head1 METHODS

=head2 new

  $ar = Archive::Ar->new()
  $ar = Archive::Ar->new($filename)
  $ar = Archive::Ar->new($filehandle)

Returns a new Archive::Ar object.  Without an argument, it returns
an empty object.  If passed a filename or an open filehandle, it will
read the referenced archive into memory.  If the read fails for any
reason, returns undef.

=head2 set_opt

  $ar->set_opt($name, $val)

Assign option $name value $val.  Possible options are:

=over 4

=item * warn

Warning level.  Levels are zero for no warnings, 1 for brief warnings,
and 2 for warnings with a stack trace.  Default is zero.

=item * chmod

Change the file permissions of files created when extracting.  Default
is true (non-zero).

=item * same_perms

When setting file permissions, use the values in the archive unchanged.
If false, removes setuid bits and applies the user's umask.  Default is
true for the root user, false otherwise.

=item * chown

Change the owners of extracted files, if possible.  Default is true.

=item * type

Archive type.  May be GNU, BSD or COMMON, or undef if no archive has
been read.  Defaults to the type of the archive read, or undef.

=item * symbols

Provide a filename for the symbol table, if present.  If set, the symbol
table is treated as a file that can be read from or written to an archive.
It is an error if the filename provided matches the name of a file in the
archive.  If undefined, the symbol table is ignored.  Defaults to undef.

=back

=head2 get_opt

  $val = $ar->get_opt($name)

Returns the value of option $name.

=head2 type

  $type = $ar->type()

Returns the type of the ar archive.  The type is undefined until an
archive is loaded.  If the archive displays characteristics of a gnu-style
archive, GNU is returned.  If it looks like a bsd-style archive, BSD
is returned.  Otherwise, COMMON is returned.  Note that unless filenames
exceed 16 characters in length, bsd archives look like the common format.

=head2 clear

  $ar->clear()

Clears the current in-memory archive.

=head2 read

  $len = $ar->read($filename)
  $len = $ar->read($filehandle)

This reads a new file into the object, removing any ar archive already
represented in the object.  The argument may be a filename, filehandle
or IO::Handle object.  Returns the size of the file contents or undef
if it fails.

=head2 read_memory

  $len = $ar->read_memory($data)

Parses the string argument as an archive, reading it into memory.  Replaces
any previously loaded archive.  Returns the number of bytes read, or undef
if it fails.

=head2 contains_file

  $bool = $ar->contains_file($filename)

Returns true if the archive contains a file with $filename.  Returns
undef otherwise.

=head2 extract

  $ar->extract()
  $ar->extract_file($filename)

Extracts files from the archive.  The first form extracts all files, the
latter extracts just the named file.  Extracted files are assigned the
permissions and modification time stored in the archive, and, if possible,
the user and group ownership.  Returns non-zero upon success, or undef if
failure.

=head2 rename

  $ar->rename($filename, $newname)

Changes the name of a file in the in-memory archive.

=head2 chmod

  $ar->chmod($filename, $mode);

Change the mode of the member to C<$mode>.

=head2 chown

  $ar->chown($filename, $uid, $gid);
  $ar->chown($filename, $uid);

Change the ownership of the member to user id C<$uid> and (optionally)
group id C<$gid>.  Negative id values are ignored.

=head2 remove

  $ar->remove(@filenames)
  $ar->remove($arrayref)

Removes files from the in-memory archive.  Returns the number of files
removed.

=head2 list_files

  @filenames = $ar->list_files()

Returns a list of the names of all the files in the archive.
If called in a scalar context, returns a reference to an array.

=head2 add_files

  $ar->add_files(@filenames)
  $ar->add_files($arrayref)

Adds files to the archive.  The arguments can be paths, but only the
filenames are stored in the archive.  Stores the uid, gid, mode, size,
and modification timestamp of the file as returned by C<stat()>.

Returns the number of files successfully added, or undef if failure.

=head2 add_data

  $ar->add_data("filename", $data)
  $ar->add_data("filename", $data, $options)

Adds a file to the in-memory archive with name $filename and content
$data.  File properties can be set with $optional_hashref:

  $options = {
      'data' => $data,
      'uid' => $uid,    #defaults to zero
      'gid' => $gid,    #defaults to zero
      'date' => $date,  #date in epoch seconds. Defaults to now.
      'mode' => $mode,  #defaults to 0100644;
  }

You cannot add_data over another file however.  This returns the file length in 
bytes if it is successful, undef otherwise.

=head2 write

  $data = $ar->write()
  $len = $ar->write($filename)

Returns the archive as a string, or writes it to disk as $filename.
Returns the archive size upon success when writing to disk.  Returns
undef if failure.

=head2 get_content

  $content = $ar->get_content($filename)

This returns a hash with the file content in it, including the data
that the file would contain.  If the file does not exist or no filename
is given, this returns undef. On success, a hash is returned:

    $content = {
        'name' => $filename,
        'date' => $mtime,
        'uid' => $uid,
        'gid' => $gid,
        'mode' => $mode,
        'size' => $size,
        'data' => $file_contents,
    }

=head2 get_data

  $data = $ar->get_data("filename")

Returns a scalar containing the file data of the given archive
member.  Upon error, returns undef.

=head2 get_handle

  $handle = $ar->get_handle("filename")>

Returns a file handle to the in-memory file data of the given archive member.
Upon error, returns undef.  This can be useful for unpacking nested archives.
Uses IO::String if it's loaded.

=head2 error

  $errstr = $ar->error($trace)

Returns the current error string, which is usually the last error reported.
If a true value is provided, returns the error message and stack trace.

=head1 BUGS

See https://github.com/jbazik/Archive-Ar/issues/ to report and view bugs.

=head1 SOURCE

The source code repository for Archive::Ar can be found at http://github.com/jbazik/Archive-Ar/.

=head1 COPYRIGHT

Copyright 2009-2014 John Bazik E<lt>jbazik@cpan.orgE<gt>.

Copyright 2003 Jay Bonci E<lt>jaybonci@cpan.orgE<gt>. 

This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

See http://www.perl.com/perl/misc/Artistic.html

=cut