home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Acorn User 10
/
AU_CD10.iso
/
Updates
/
Perl
/
Non-RPC
/
!Perl
/
scripts
/
listalf
< prev
next >
Wrap
Text File
|
1998-07-14
|
5KB
|
176 lines
#!perl -lw
# Version 0.02
# A perl version of Gareth's listalf.
# Somewhat slower.
# Considereably more hackable.
use strict;
use RISCOS::Throwback;
use RISCOS::File ':DEFAULT', '/glob/';
use RISCOS::Filespec;
use RISCOS::Chunkfile;
use RISCOS::AOF;
use RISCOS::ALF;
use RISCOS::Time qw (time2utc time2local);
# Keep paths intact (eg Unix:o.UnixLib
glob_control (&fileglob_PrintOriginalPath);
use Getopt::Std;
use vars qw(%opt $VERSION);
$VERSION = 0.02;
getopts ('?nmtsoyiclv', \%opt);
$opt{'m'}= $opt{'n'} = 1 unless keys (%opt);
sub do_file
{
my $file = shift;
my $chunks = new RISCOS::Chunkfile shift;
my $entry = shift;
# So that name and data source can differ
unless (defined $chunks) {
warn "'$file' is not a chunkfile";
}
elsif ($chunks->Lookup ('OBJ_HEAD'))
{
# izza AOF
warn "File '$file' is AOF\n";
}
elsif ($chunks->Lookup ('LIB_DIRY'))
{
if (my $library = new RISCOS::ALF $chunks) {
# izza ALF
if ($entry) {
&do_alf ($library, $file, $library->Dir_Lookup ($entry));
} else {
&do_alf ($library, $file, values %{$library->Dir});
}
}
}
else
{
warn "'$file' is not a recognised chunkfile - contains "
. join (', ', keys %{$chunks->Index}) . ' chunks';
}
}
sub do_alf ($$;@) {
my $library = shift;
my $file = shift;
my $maxlen = 0;
my $maxoff = 0;
my $maxsize = 0;
my $formatnum = 1 + int (log (2 + scalar @_) / log 10);
my $count = 0;
foreach (@_) {
my ($len, $size, $off) = (length $_->Name(), $_->Chunk()->Length(),
$_->Chunk()->Offset());
$maxlen = $len if $len > $maxlen;
$maxsize = $size if $size > $maxsize;
$maxoff = $off if $off > $maxoff;
$count++;
}
if ($opt{'l'}) {
print "Library file '$file':";
print ' ALF version ', $library->Version;
print ' contents updated ', scalar time2local $library->Time->Time;
print ' symtable updated ', scalar time2local $library->Sym_Time->Time;
print ' ', $count, ' member', $count == 1 ? '' : 's';
print '-' x 60;
}
my $formatoff = 1 + int (log ($maxoff) / log 16);
my $formatsize = 1 + int (log ($maxsize) / log 10);
foreach (sort {$a->Index() <=> $b->Index()} @_) {
# Reference to chunk data means "treat this as file to load"
my (@line, $size);
push @line, sprintf "%${formatnum}d", $_->Index() if $opt{'n'};
push @line, sprintf "%-${maxlen}s", $_->Name() if $opt{'m'};
if ($opt{'s'} or $opt{'o'}) {
my @so;
@so =
sprintf "%${formatsize}d", $_->Chunk->Length();
push @so,
sprintf "at &%0${formatoff}X", $_->Chunk->Offset();
push @line, join ' ', @so;
}
push @line, scalar time2local ($_->Time->Time) if $opt{'t'};
if ($opt{'s'} or $opt{'i'} or $opt{'c'}) {
my $aof = new RISCOS::AOF \($_->Chunk->Data);
if ($aof) {
if ($opt{'c'}) {
my @symbols;
foreach my $symbol (@{$aof->Symbols}) {
push @symbols, $symbol->Name() if $symbol->Scope eq '';
}
print join ' : ', @line, (join ' ', @symbols);
} elsif ($opt{'i'}) {
foreach my $symbol (@{$aof->Symbols}) {
print join ' : ', @line, $symbol->Name()
if $symbol->Scope eq '';
}
} else {
print join ' : ', @line;
foreach my $symbol (@{$aof->Symbols}) {
print ' | ' . $symbol->Name()
if $symbol->Scope eq '';
}
}
} else {
warn 'Failed to extract symbols from ' . $_->Name();
print join ' : ', @line if @line;
}
} else {
print join ' : ', @line if @line;
}
# print "$file,", $_->Name(), ' : ', $_->Index();
}
}
if ($opt{'v'}) {
print STDERR "This is $0 version $VERSION";
exit;
}
if ($opt{'?'}) {
print STDERR <<"!!";
$0, version $VERSION
Options:
-n --numbers display chunk numbers
-m --members display membernames
-t --timestamps display timestamps of members
-s --sizes display sizes of members
-o --offsets display offsets of members within file
-y --symbols display symbol table
-i --inline display symbols on same line as other stuff
-c --compact ditto, with all symbols on one line
-l --lib-info display ALF version, library timestamp etc
-v --version print version number of this program
If no options are given, -nm is assumed.
!!
exit 0;
}
foreach (@ARGV)
{
# Try to make the entry the longest comma free string possible
my ($file, $entry) = ($_);
# Found a comma? If so separate as it's probably a $file,$entry for ALF
($file, $entry) = /^(.*?),?([^,]*)$/ if tr/,//;
my @files = glob ($file);
@files = $file unless @files; # Push pattern if unmatched
foreach $file (@files)
{
do_file ($file, $file, $entry);
}
}