0: package Archive::Ar;
1:
2: ###########################################################
3: # Archive::Ar - Pure perl module to handle ar achives
4: #
5: # Copyright 2003 - Jay Bonci <jaybonci@cpan.org>
6: # Licensed under the same terms as perl itself
7: #
8: ###########################################################
9:
10: use strict;
11: use Exporter;
12: use File::Spec;
13: use Time::Local;
14:
15: use vars qw($VERSION @ISA @EXPORT);
16: $VERSION = '1.1';
17:
18: use constant ARMAG => "!<arch>\n";
19: use constant SARMAG => length(ARMAG);
20: use constant ARFMAG => "`\n";
21:
22: @ISA=qw(Exporter);
23: @EXPORT=qw/read read_memory list_files add_files add_data write get_content DEBUG/;
24:
25: sub new {
26: my ($class, $filenameorhandle, $debug) = @_;
27:
28: my $this = {};
29:
30: my $obj = bless $this, $class;
31:
32: $obj->{_verbose} = 0;
33: $obj->_initValues();
34:
35:
36: if($debug)
37: {
38: $obj->DEBUG();
39: }
40:
41: if($filenameorhandle){
42: unless($obj->read($filenameorhandle)){
43: $obj->_dowarn("new() failed on filename or filehandle read");
44: return;
45: }
46: }
47:
48: return $obj;
49: }
50:
51: sub read
52: {
53: my ($this, $filenameorhandle) = @_;
54:
55: my $retval;
56:
57: $this->_initValues();
58:
59: if(ref $filenameorhandle eq "GLOB")
60: {
61: unless($retval = $this->_readFromFilehandle($filenameorhandle))
62: {
63: $this->_dowarn("Read from filehandle failed");
64: return;
65: }
66: }else
67: {
68: unless($retval = $this->_readFromFilename($filenameorhandle))
69: {
70: $this->_dowarn("Read from filename failed");
71: return;
72: }
73: }
74:
75:
76: unless($this->_parseData())
77: {
78: $this->_dowarn("read() failed on data structure analysis. Probable bad file");
79: return;
80: }
81:
82:
83: return $retval;
84: }
85:
86: sub read_memory
87: {
88: my ($this, $data) = @_;
89:
90: $this->_initValues();
91:
92: unless($data)
93: {
94: $this->_dowarn("read_memory() can't continue because no data was given");
95: return;
96: }
97:
98: $this->{_filedata} = $data;
99:
100: unless($this->_parseData())
101: {
102: $this->_dowarn("read_memory() failed on data structure analysis. Probable bad file");
103: return;
104: }
105:
106: return length($data);
107: }
108:
109: sub list_files
110: {
111: my($this) = @_;
112:
113: return \@{$this->{_files}};
114:
115: }
116:
117: sub add_files
118: {
119: my($this, $filenameorarray, @otherfiles) = @_;
120:
121: my $filelist;
122:
123: if(ref $filenameorarray eq "ARRAY")
124: {
125: $filelist = $filenameorarray;
126: }else
127: {
128: $filelist = [$filenameorarray];
129: if(@otherfiles)
130: {
131: push @$filelist, @otherfiles;
132: }
133: }
134:
135: my $filecount = 0;
136:
137: foreach my $filename (@$filelist)
138: {
139: my @props = stat($filename);
140: unless(@props)
141: {
142: $this->_dowarn("Could not stat() filename. add_files() for this file failed");
143: next;
144: }
145: my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = @props;
146:
147: my $header = {
148: "date" => $mtime,
149: "uid" => $uid,
150: "gid" => $gid,
151: "mode" => $mode,
152: "size" => $size,
153: };
154:
155: local $/ = undef;
156: unless(open HANDLE, $filename)
157: {
158: $this->_dowarn("Could not open filename. add_files() for this file failed");
159: next;
160: }
161: $header->{data} = <HANDLE>;
162: close HANDLE;
163:
164: # fix the filename
165:
166: (undef, undef, $filename) = File::Spec->splitpath($filename);
167: $header->{name} = $filename;
168:
169: $this->_addFile($header);
170:
171: $filecount++;
172: }
173:
174: return $filecount;
175: }
176:
177: sub add_data
178: {
179: my($this, $filename, $data, $params) = @_;
180: unless ($filename)
181: {
182: $this->_dowarn("No filename given; add_data() can't proceed");
183: return;
184: }
185:
186: $params ||= {};
187: $data ||= "";
188:
189: (undef, undef, $filename) = File::Spec->splitpath($filename);
190:
191: $params->{name} = $filename;
192: $params->{size} = length($data);
193: $params->{data} = $data;
194: $params->{uid} ||= 0;
195: $params->{gid} ||= 0;
196: $params->{date} ||= timelocal(localtime());
197: $params->{mode} ||= "100644";
198:
199: unless($this->_addFile($params))
200: {
201: $this->_dowarn("add_data failed due to a failure in _addFile");
202: return;
203: }
204:
205: return $params->{size};
206: }
207:
208: sub write
209: {
210: my($this, $filename) = @_;
211:
212: my $outstr;
213:
214: $outstr= ARMAG;
215: foreach(@{$this->{_files}})
216: {
217: my $content = $this->get_content($_);
218: unless($content)
219: {
220: $this->_dowarn("Internal Error. $_ file in _files list but no filedata");
221: next;
222: }
223:
224:
225: # For whatever reason, the uids and gids get stripped
226: # if they are zero. We'll blank them here to emulate that
227:
228: $content->{uid} ||= "";
229: $content->{gid} ||= "";
230:
231: $outstr.= pack("A16A12A6A6A8A10", @$content{qw/name date uid gid mode size/});
232: $outstr.= ARFMAG;
233: $outstr.= $content->{data};
234: }
235:
236: return $outstr unless $filename;
237:
238: unless(open HANDLE, ">$filename")
239: {
240: $this->_dowarn("Can't open filename $filename");
241: return;
242: }
243: print HANDLE $outstr;
244: close HANDLE;
245: return length($outstr);
246: }
247:
248: sub get_content
249: {
250: my ($this, $filename) = @_;
251:
252: unless($filename)
253: {
254: $this->_dowarn("get_content can't continue without a filename");
255: return;
256: }
257:
258: unless(exists($this->{_filehash}->{$filename}))
259: {
260: $this->_dowarn("get_content failed because there is not a file named $filename");
261: return;
262: }
263:
264: return $this->{_filehash}->{$filename};
265: }
266:
267: sub DEBUG
268: {
269: my($this, $verbose) = @_;
270: $verbose = 1 unless(defined($verbose) and int($verbose) == 0);
271: $this->{_verbose} = $verbose;
272: return;
273:
274: }
275:
276: sub _parseData
277: {
278: my($this) = @_;
279:
280: unless($this->{_filedata})
281: {
282: $this->_dowarn("Cannot parse this archive. It appears to be blank");
283: return;
284: }
285:
286: my $scratchdata = $this->{_filedata};
287:
288: unless(substr($scratchdata, 0, SARMAG, "") eq ARMAG)
289: {
290: $this->_dowarn("Bad magic header token. Either this file is not an ar archive, or it is damaged. If you are sure of the file integrity, Archive::Ar may not support this type of ar archive currently. Please report this as a bug");
291: return "";
292: }
293:
294: while($scratchdata =~ /\S/)
295: {
296:
297: if($scratchdata =~ s/^(.{58})`\n//m)
298: {
299: my @fields = unpack("A16A12A6A6A8A10", $1);
300:
301: for(0..@fields)
302: {
303: $fields[$_] ||= "";
304: $fields[$_] =~ s/\s*$//g;
305: }
306:
307: my $headers = {};
308: @$headers{qw/name date uid gid mode size/} = @fields;
309:
310: $headers->{data} = substr($scratchdata, 0, $headers->{size}, "");
311:
312: $this->_addFile($headers);
313: }else{
314: $this->_dowarn("File format appears to be corrupt. The file header is not of the right size, or does not exist at all");
315: return;
316: }
317: }
318:
319: return scalar($this->{_files});
320: }
321:
322: sub _readFromFilename
323: {
324: my ($this, $filename) = @_;
325:
326: my $handle;
327: open $handle, $filename or return;
328: return $this->_readFromFilehandle($handle);
329: }
330:
331:
332: sub _readFromFilehandle
333: {
334: my ($this, $filehandle) = @_;
335: return unless $filehandle;
336:
337: #handle has to be open
338: return unless(fileno $filehandle);
339:
340: local $/ = undef;
341: $this->{_filedata} = <$filehandle>;
342: close $filehandle;
343:
344: return length($this->{_filedata});
345: }
346:
347: sub _addFile
348: {
349: my ($this, $file) = @_;
350:
351: return unless $file;
352:
353: foreach(qw/name date uid gid mode size data/)
354: {
355: unless(exists($file->{$_}))
356: {
357: $this->_dowarn("Can't _addFile because virtual file is missing $_ parameter");
358: return;
359: }
360: }
361:
362: if(exists($this->{_filehash}->{$file->{name}}))
363: {
364: $this->_dowarn("Can't _addFile because virtual file already exists with that name in the archive");
365: return;
366: }
367:
368: push @{$this->{_files}}, $file->{name};
369: $this->{_filehash}->{$file->{name}} = $file;
370:
371: return $file->{name};
372: }
373:
374: sub _initValues
375: {
376: my ($this) = @_;
377:
378: $this->{_files} = [];
379: $this->{_filehash} = {};
380: $this->{_filedata} ="";
381:
382: return;
383: }
384:
385: sub _dowarn
386: {
387: my ($this, $warning) = @_;
388:
389: if($this->{_verbose})
390: {
391: warn "DEBUG: $warning";
392: }
393:
394: return;
395: }
396:
397: 1;
398:
399:
400: =head1 NAME
401:
402: Archive::Ar - Interface for manipulating ar archives
403:
404: =head1 SYNOPSIS
405:
406: use Archive::Ar;
407:
408: my $ar = new Archive::Ar("./foo.ar");
409:
410: $ar->add_data("newfile.txt","Some contents", $properties);
411:
412: $ar->add_files("./bar.tar.gz", "bat.pl")
413: $ar->add_files(["./again.gz"]);
414:
415: my $filedata = $ar->get_content("bar.tar.gz");
416:
417: my @files = $ar->list_files();
418: $ar->read("foo.deb");
419:
420: $ar->write("outbound.ar");
421:
422: $ar->DEBUG();
423:
424:
425: =head1 DESCRIPTION
426:
427: Archive::Ar is a pure-perl way to handle standard ar archives.
428:
429: This is useful if you have those types of old archives on the system, but it
430: is also useful because .deb packages for the Debian GNU/Linux distribution are
431: ar archives. This is one building block in a future chain of modules to build,
432: manipulate, extrace, and test debian modules with no platform or architecture
433: independance.
434:
435: You may notice that the API to Archive::Ar is similar to Archive::Tar, and
436: this was done intentionally to keep similarity between the Archive::*
437: modules
438:
439:
440: =head2 Class Methods
441:
442: =over 4
443:
444: =item new()
445: =item new($filename);
446: =item new(*GLOB, $debug);
447:
448: Returns a new Archive::Ar object. Without a filename or glob, it returns an
449: empty object. If passed a filename as a scalar or in a GLOB, it will attempt
450: to populate from either of those sources. If it fails, you will receive
451: undef, instead of an object reference.
452:
453: This also can take a second optional debugging parameter. This acts exactly
454: as if DEBUG() is called on the object before it is returned. If you have a
455: new() that keeps failing, this should help.
456:
457: =item read($filename)
458: =item read(*GLOB);
459:
460: This reads a new file into the object, removing any ar archive already
461: represented in the object. Any calls to DEBUG() are not lost by reading
462: in a new file. Returns the number of bytes read, undef on failure.
463:
464: =item read_memory($data)
465:
466: This read information from the first parameter, and attempts to parse and treat
467: it like an ar archive. Like read(), it will wipe out whatever you have in the
468: object and replace it with the contents of the new archive, even if it fails.
469: Returns the number of bytes read (processed) if successful, undef otherwise.
470:
471: =item list_files()
472:
473: This lists the files contained inside of the archive by filename, as an
474: array.
475:
476: =item add_files("filename1", "filename2")
477: =item add_files(["filename1", "filename2"])
478:
479: Takes an array or an arrayref of filenames to add to the ar archive, in order.
480: The filenames can be paths to files, in which case the path information is
481: stripped off. Filenames longer than 16 characters are truncated when written
482: to disk in the format, so keep that in mind when adding files.
483:
484: Due to the nature of the ar archive format, add_files() will store the uid,
485: gid, mode, size, and creation date of the file as returned by stat();
486:
487: add_files() returns the number of files sucessfully added, or undef on failure.
488:
489: =item add_data("filename", $filedata)
490:
491: Takes an filename and a set of data to represent it. Unlike add_files, add_data
492: is a virtual add, and does not require data on disk to be present. The
493: data is a hash that looks like:
494:
495: $filedata = {
496: "data" => $data,
497: "uid" => $uid, #defaults to zero
498: "gid" => $gid, #defaults to zero
499: "date" => $date, #date in epoch seconds. Defaults to now.
500: "mode" => $mode, #defaults to "100644";
501: }
502:
503: You cannot add_data over another file however. This returns the file length in
504: bytes if it is successful, undef otherwise.
505:
506: =item write()
507: =item write("filename.ar")
508:
509: This method will return the data as an .ar archive, or will write to the
510: filename present if specified. If given a filename, write() will return the
511: length of the file written, in bytes, or undef on failure. If the filename
512: already exists, it will overwrite that file.
513:
514: =item get_content("filename")
515:
516: This returns a hash with the file content in it, including the data that the
517: file would naturally contain. If the file does not exist or no filename is
518: given, this returns undef. On success, a hash is returned with the following
519: keys:
520:
521: name - The file name
522: date - The file date (in epoch seconds)
523: uid - The uid of the file
524: gid - The gid of the file
525: mode - The mode permissions
526: size - The size (in bytes) of the file
527: data - The contained data
528:
529: =item DEBUG()
530:
531: This method turns on debugging. Optionally this can be done by passing in a
532: value as the second parameter to new. While verbosity is enabled,
533: Archive::Ar will toss a warn() if there is a suspicious condition or other
534: problem while proceeding. This should help iron out any problems you have
535: while using the module.
536:
537: =head1 CHANGES
538:
539: =over 4
540:
541: =item Version 1.1
542:
543: Documentation cleanups
544:
545: =item Version 1.0
546:
547: This is the initial public release for CPAN, so everything is new.
548:
549: =head1 TODO
550:
551: A better unit test suite perhaps. I have a private one, but a public one would be
552: nice if there was good file faking module.
553:
554: Fix / investigate stuff in the BUGS section.
555:
556: =head1 BUGS
557:
558: To be honest, I'm not sure of a couple of things. The first is that I know
559: of ar archives made on old AIX systems (pre 4.3?) that have a different header
560: with a different magic string, etc. This module perfectly (hopefully) handles
561: ar archives made with the modern ar command from the binutils distribtuion. If
562: anyone knows of anyway to produce these old-style AIX archives, or would like
563: to produce a few for testing, I would be much grateful.
564:
565: There's no really good reason why this module /shouldn't/ run on Win32
566: platforms, but admittedly, this might change when we have a file exporting
567: function that supports owner and permission writing.
568:
569: If you read in and write out a file, you get different md5sums, but it's still
570: a valid archive. I'm still investigating this, and consider it a minor bug.
571:
572: =head1 COPYRIGHT
573:
574: Archive::Ar is copyright 2003 Jay Bonci E<lt>jaybonci@cpan.orgE<gt>.
575: This program is free software; you can redistribute it and/or modify it under
576: the same terms as Perl itself.
577:
578: =cut
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.