cvsuser 01/09/17 14:54:07
Modified: . MANIFEST
Added: Parrot PackFile.pm
Parrot/PackFile ConstTable.pm Constant.pm FixupTable.pm
Log:
Functions for reading, writing and manipulating Parrot Pack Files. NOTE: This
is a proposed term based on the fact that the file contains more than just byte
code, and another language (Java) calls its binary files by a broader notion of
what's in them (Class Files). Since Perl has packages, and since we use pack()
to write them, we'll call them PackFiles (at least for now).
That does, however, beg the question of file extension. Should we name the
files "foo.pack" instead of "foo.pbc"?
Revision Changes Path
1.12 +4 -0 parrot/MANIFEST
Index: MANIFEST
===================================================================
RCS file: /home/perlcvs/parrot/MANIFEST,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -w -r1.11 -r1.12
--- MANIFEST 2001/09/17 14:20:26 1.11
+++ MANIFEST 2001/09/17 21:54:07 1.12
@@ -3,6 +3,10 @@
Makefile.in
MANIFEST
Parrot/Opcode.pm
+Parrot/PackFile.pm
+Parrot/PackFile/Constant.pm
+Parrot/PackFile/ConstTable.pm
+Parrot/PackFile/FixupTable.pm
Parrot/Test.pm
README
TODO
1.1 parrot/Parrot/PackFile.pm
Index: PackFile.pm
===================================================================
#!/usr/bin/perl -w
#
# PackFile.pm
#
# Parrot::PackFile Perl package. Functions for reading, writing and manipulating
# Parrot Pack Files. NOTE: This is a proposed term based on the fact that the
# file contains more than just byte code, and another language (Java) calls
# its binary files by a broader notion of what's in them (Class Files). Since
# Perl has packages, and since we use pack() to write them, we'll call them
# PackFiles (at least for now).
#
# That does, however, beg the question of file extension. Should we name the
# files "foo.pack" instead of "foo.pbc"?
#
# Copyright (C) 2001 Gregor N. Purdy. All rights reserved.
# This program is free software. It is subject to the same
# license as Perl itself.
#
# $Id: PackFile.pm,v 1.1 2001/09/17 21:54:07 gregor Exp $
#
use strict;
package Parrot::PackFile;
use Parrot::PackFile::FixupTable;
use Parrot::PackFile::ConstTable;
use FileHandle;
my $PARROT_MAGIC = 0x13155a1;
my $template = "l l/a* l/a* l/a*";
#
# new()
#
sub new
{
my $class = shift;
my $self = bless {
MAGIC => $PARROT_MAGIC,
FIXUP => Parrot::PackFile::FixupTable->new(),
CONST => Parrot::PackFile::ConstTable->new(),
PROG => '',
}, $class;
return $self;
}
#
# magic()
#
sub magic
{
return $PARROT_MAGIC;
}
#
# fixup_table()
#
sub fixup_table
{
my $self = shift;
return $self->{FIXUP};
}
#
# const_table()
#
sub const_table
{
my $self = shift;
return $self->{FIXUP};
}
#
# byte_code()
#
sub byte_code
{
my $self = shift;
if (@_) { $self->{BCODE} = shift; }
else { return $self->{BCODE}; }
}
#
# unpack()
#
# Magic: 4-byte signed integer
# Fixup: 4-byte length N + N bytes
# Const: 4-byte length N + N bytes
# BCode: N bytes
#
sub unpack
{
my ($self, $string) = @_;
printf "Input string is %d bytes long\n", length($string);
my $magic = unpack("l", $string);
$string = substr($string, 4);
$self->{MAGIC} = $magic;
die "Bad PARROT_MAGIC" unless $magic == $PARROT_MAGIC;
#
# Read the fixup table:
#
my $fixup = '';
my $fixup_length = unpack('l', $string);
$string = substr($string, 4);
if($fixup_length) {
$fixup = unpack("a$fixup_length", $string);
$string = substr($string, $fixup_length);
$self->{FIXUP}->unpack($fixup);
} else {
$self->{FIXUP}->clear;
}
#
# Read the constant table:
#
my $const = '';
my $const_length = unpack('l', $string);
$string = substr($string, 4);
if($const_length) {
$const = unpack("a$const_length", $string);
$string = substr($string, $const_length);
$self->{CONST}->unpack($const);
} else {
$self->{CONST}->clear;
}
#
# Read the byte code:
#
# TODO: This is wrong. It should be a length-payload pair like the
# rest of the segments, but the assembler and interpreter and
# disassembler all agree on this implementation despite the docs.
#
$self->{BCODE} = $string;
#
# Report on what we found:
#
printf " * %6d bytes magic\n", 4;
printf " * %6d bytes fixup segment header\n", 4;
printf " * %6d bytes fixup\n", length($fixup);
printf " * %6d bytes const segment header\n", 4;
printf " * %6d bytes const\n", length($const);
printf " * %6d bytes bcode\n", length($string);
# printf "Parsed string with %d bytes of fixup, %d bytes of const and %d bytes of
prog.\n", length($fixup), length($const), length($prog);
# my $packed = pack($template, $magic, $fixup, $const, $bcode);
# printf "Packed is %d bytes long\n", length($packed);
return $self;
}
#
# read_filehandle()
#
sub read_filehandle
{
my ($self, $fh) = @_;
return unless $fh;
my @lines = $fh->getlines();
my $string = join('', @lines);
printf "Read %d lines, %d bytes.\n", scalar(@lines), length($string);
return $self->unpack($string);
}
#
# read_file()
#
sub read_file
{
my $self = shift;
my $fh = new FileHandle(shift);
return unless $fh;
return $self->read_filehandle($fh);
}
#
# pack()
#
sub pack
{
my $self = shift;
my $string = '';
$string .= pack('l', $self->magic);
my $fixup = $self->fixup_table->pack;
my $const = $self->const_table->pack;
$string .= pack('l', length($fixup));
$string .= $fixup;
$string .= pack('l', length($const));
$string .= $const;
#
# TODO: It is wrong not to write this length, because then we can't have
# another source-code segment, which the docs say we should be able to
# have.
#
# $string .= pack('l', length($self->byte_code));
$string .= $self->byte_code;
return $string;
}
#
# write_filehandle()
#
sub write_filehandle
{
my ($self, $fh) = @_;
print($fh $self->pack);
}
#
# write_file()
#
sub write_file
{
my $self = shift;
my $fh = new FileHandle('>' . shift);
return unless $fh;
return $self->write_filehandle($fh);
}
1;
__END__
=head1 NAME
Parrot::Bytecode
=head1 SYNOPSIS
use Parrot::Bytecode;
=head1 DESCRIPTION
This package contains all the functions required to process a Parrot bytecode
file. It is not intended to understand the contents of the bytecode file's
segments, but merely to dissect and reconstruct data from the various
segments. See L<parrotbyte> for information about the structure of the frozen
bycode.
=head1 FORMAT
0
+----------+----------+----------+----------+
| Parrot Magic = 0x 13155a1 |
+----------+----------+----------+----------+
For each segment:
4, 4 + (4 + S0), 4 + (4 + S0) + (4 + S1)
+----------+----------+----------+----------+
| Segment length in bytes (S) |
+----------+----------+----------+----------+
| |
: S bytes of segment content :
| |
+----------+----------+----------+----------+
NOTE: Despite the documentation, current implementations consist
of two actual segments (fixup and const) followed by a block of
byte code, which is not in a proper segment.
=head2 FIXUP SEGMENT
TODO: Segment format undefined.
=head2 CONSTANTS SEGMENT
0 (relative)
+----------+----------+----------+----------+
| Constant Count (N) |
+----------+----------+----------+----------+
For each constant:
4, 4 + (16 + S'0), 4 + (16 + S'0) + (16 + S'1)
+----------+----------+----------+----------+
| Flags |
+----------+----------+----------+----------+
| Encoding |
+----------+----------+----------+----------+
| Type |
+----------+----------+----------+----------+
| Size S |
+----------+----------+----------+----------+
| |
: S' bytes of Data (w/ S % 4 pad \0 bytes) |
| |
+----------+----------+----------+----------+
=head2 BYTE CODE SEGMENT
The pieces that can be found in the byte code segment are as
follows:
+----------+----------+----------+----------+
| Operation Code |
+----------+----------+----------+----------+
+----------+----------+----------+----------+
| Register Argument |
+----------+----------+----------+----------+
+----------+----------+----------+----------+
| Integer Constant Argument |
+----------+----------+----------+----------+
+----------+----------+----------+----------+
| String Constant Argument |
+----------+----------+----------+----------+
+----------+----------+----------+----------+
| Number Constant Argument |
+ +
| |
+----------+----------+----------+----------+
+----------+----------+----------+----------+
| Constant Argument |
+----------+----------+----------+----------+
The number and types for each argument can be determined by
consulting Parrot::Opcode.
=head2 SOURCE CODE SEGMENT
=head1 AUTHOR
Gregor N. Purdy E<lt>[EMAIL PROTECTED]<gt>
=head1 COPYRIGHT
Copyright (C) 2001 Gregor N. Purdy. All rights reserved.
=head1 LICENSE
This program is free software. It is subject to the same
license as Perl itself.
1.1 parrot/Parrot/PackFile/ConstTable.pm
Index: ConstTable.pm
===================================================================
#!/usr/bin/perl -w
#
# ConstTable.pm
#
# Parrot::ConstTable Perl package. Functions for manipulating Parrot
# bytecode constant tables.
#
# Copyright (C) 2001 Gregor N. Purdy. All rights reserved.
# This program is free software. It is subject to the same
# license as Perl itself.
#
# $Id: ConstTable.pm,v 1.1 2001/09/17 21:54:07 gregor Exp $
#
use strict;
package Parrot::PackFile::ConstTable;
use Parrot::PackFile::Constant;
my $template = "l/(l l l l/a*)*";
#
# new()
#
sub new
{
my $class = shift;
my $self = bless { CONST => [ ] }, $class;
if (@_) {
$self->unpack(shift);
}
return $self;
}
#
# clear()
#
sub clear
{
my $self = shift;
$self->{CONST} = [ ];
return;
}
#
# unpack()
#
sub unpack
{
my ($self, $string) = @_;
my $count = unpack 'l', $string;
$string = substr($string, 4);
for (1..$count) {
my $const = new Parrot::PackFile::Constant;
my $used = $const->unpack($string);
$string = substr($string, $used);
push @{$self->{CONST}}, $const;
}
}
#
# pack()
#
sub pack
{
my $self = shift;
my $string = '';
$string .= pack('l', scalar(@{$self->{CONST}}));
foreach (@{$self->{CONST}}) {
$string .= $_->pack;
}
return $string;
}
1;
__END__
=head1 NAME
Parrot::PackFile::ConstTable
=head1 SYNOPSIS
use Parrot::PackFile::ConstTable
=head1 DESCRIPTION
Constant tables from Parrot pack files.
=head2 clear
=head2 new
=head2 pack
=head2 unpack STRING
=head1 AUTHOR
Gregor N. Purdy E<lt>[EMAIL PROTECTED]<gt>
=head1 COPYRIGHT
Copyright (C) 2001 Gregor N. Purdy. All rights reserved.
=head1 LICENSE
This program is free software. It is subject to the same
license as Perl itself.
1.1 parrot/Parrot/PackFile/Constant.pm
Index: Constant.pm
===================================================================
#!/usr/bin/perl -w
#
# Constant.pm
#
# Parrot Constants.
#
# Copyright (C) 2001 Gregor N. Purdy. All rights reserved.
# This program is free software. It is subject to the same
# license as Perl itself.
#
# $Id: Constant.pm,v 1.1 2001/09/17 21:54:07 gregor Exp $
#
use strict;
package Parrot::PackFile::Constant;
my $template = "l l l l/a*";
#
# new()
#
sub new
{
my $class = shift;
my ($flags, $encoding, $type, $size, $data) = @_;
my $self = bless {
FLAGS => $flags,
ENCODING => $encoding,
TYPE => $type,
SIZE => $size,
DATA => $data
}, $class;
return $self;
}
#
# flags()
#
sub flags
{
my $self = shift;
if (@_) { $self->{FLAGS} = shift; }
else { return $self->{FLAGS}; }
}
#
# encoding()
#
sub encoding
{
my $self = shift;
if (@_) { $self->{ENCODING} = shift; }
else { return $self->{ENCODING}; }
}
#
# type()
#
sub type
{
my $self = shift;
if (@_) { $self->{TYPE} = shift; }
else { return $self->{TYPE}; }
}
#
# size()
#
sub size
{
my $self = shift;
if (@_) { $self->{SIZE} = shift; }
else { return $self->{SIZE}; }
}
#
# data()
#
sub data
{
my $self = shift;
if (@_) { $self->{DATA} = shift; }
else { return $self->{DATA}; }
}
#
# unpack()
#
# Unpack from the string and return the number of characters that should
# be removed from the string.
#
sub unpack
{
my ($self, $string) = @_;
my ($flags, $encoding, $type, $size, $data) = unpack($template, $string);
return $size + ($size % 4);
}
#
# pack()
#
sub pack
{
my $self = shift;
my $block = $self->data . ("\0" x ($self->size % 4));
return pack($template, $self->flags, $self->encoding, $self->type, $self->size,
$block);
}
1;
__END__
=head1 NAME
Parrot::PackFile::Constant
=head1 SYNOPSIS
use Parrot::PackFile::Constant;
=head1 DESCRIPTION
=head2 data DATA
=head2 data
=head2 encoding ENCODING
=head2 encoding
=head2 flags FLAGS
=head2 flags
=head2 new FLAGS ENCODING TYPE SIZE DATA
=head2 pack
=head2 size SIZE
=head2 size
=head2 type TYPE
=head2 type
=head2 unpack STRING
=head2 unpack
=head1 AUTHOR
Gregor N. Purdy E<lt>[EMAIL PROTECTED]<gt>
=head1 COPYRIGHT
Copyright (C) 2001 Gregor N. Purdy. All rights reserved.
=head1 LICENSE
This program is free software. It is subject to the same
license as Perl itself.
1.1 parrot/Parrot/PackFile/FixupTable.pm
Index: FixupTable.pm
===================================================================
#!/usr/bin/perl -w
#
# FixupTable.pm
#
# Parrot::FixupTable Perl package. Functions for manipulating Parrot
# bytecode fixup tables.
#
# Copyright (C) 2001 Gregor N. Purdy. All rights reserved.
# This program is free software. It is subject to the same
# license as Perl itself.
#
# $Id: FixupTable.pm,v 1.1 2001/09/17 21:54:07 gregor Exp $
#
use strict;
package Parrot::PackFile::FixupTable;
#
# new()
#
sub new
{
my $class = shift;
my $self = bless { }, $class;
if (@_) {
$self->unpack(shift);
}
return $self;
}
#
# clear()
#
sub clear
{
my $self = shift;
return;
}
#
# unpack()
#
sub unpack
{
my $self = shift;
}
#
# pack()
#
sub pack
{
my $self = shift;
return '';
}
1;
__END__
=head1 NAME
Parrot::PackFile::FixupTable
=head1 SYNOPSIS
use Parrot::PackFile::FixupTable;
=head1 DESCRIPTION
Parrot fixup tables.
=head2 clear
=head2 new
=head2 pack
=head2 unpack
=head1 AUTHOR
Gregor N. Purdy E<lt>[EMAIL PROTECTED]<gt>
=head1 COPYRIGHT
Copyright (C) 2001 Gregor N. Purdy. All rights reserved.
=head1 LICENSE
This program is free software. It is subject to the same
license as Perl itself.
