Acorn User 10/AU_CD10.iso/Updates/Perl/Non-RPC/!Perl/scripts/listalf

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);
    }
}