Beefy Boxes and Bandwidth Generously Provided by pair Networks
Do you know where your variables are?
 
PerlMonks  

comment on

( [id://3333]=superdoc: print w/replies, xml ) Need Help??
    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
    

In reply to Archive::Ar - pure perl way to handle Ar archives (comments encouraged) by JayBonci

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • 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.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others imbibing at the Monastery: (6)
As of 2024-03-28 14:13 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found