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