ACME-6502/lib/TieMem.pm

#package Tie::Filter::Array;
package TieMem;

use 5.008;
use strict;
use warnings;

use Carp qw/confess/;
use base qw/Tie::Array/;

use Data::Dump qw/dump/;

our $VERSION = '1.02';

=head1 NAME

Tie::Filter::Array - Tie a facade around an array

=head1 DESCRIPTION

Don't use this package directly. Instead, see L<Tie::Filter>.

=cut

sub _read {
        my ( $self, $index ) = @_;
        my $value = $$self{WRAP}[$index];
        confess "write undef value to $index" unless defined($value);
#       printf "_read(%04x) = %2x %d\n", $index, $value, $value;
        $self->{mem_acc}->( $index, 'read' );
        return $value;
}

sub _write {
        my ( $self, $index, $value ) = @_;
        if ( $index >= 0x6000 && $index < 0x8000 ) {
                $self->{vram}->( $index, $value );
        }
        confess "write undef value to $index" unless defined($value);
#       printf "_write(%04x) = %2x %d\n", $index, $value, $value;
        $self->{mem_acc}->( $index, 'write' );
        $$self{WRAP}[$index] = $value;
}

my @ram = (0) x 65535;

sub TIEARRAY {
        my %self;
        my ($class, $args) = @_;
        warn "tiemem",dump( $class, $args );
        $self{WRAP} = \@ram;
        foreach my $p ( qw/vram mem_acc/ ) {
                $self{$p} = $args->{$p} || die "no $p ?";
        }
        return bless \%self, $class;
}

sub FETCH {
        my ($self, $index) = @_;
        $self->_read($index);
}

sub STORE {
        my ($self, $index, $value) = @_;
        $self->_write( $index, $value );
}

sub FETCHSIZE {
        my $self = shift;
        scalar(@{$$self{WRAP}});
}

sub STORESIZE {
        my ($self, $count) = @_;
        $#{$$self{WRAP}} = $count - 1;
}

# TODO (?) Detect if the wrappee is tied and call it's EXTEND if it is,
# otherwise do nothing.
sub EXTEND { }

sub EXISTS {
        my ($self, $index) = @_;
        exists $$self{WRAP}[$index];
}

sub DELETE {
        my ($self, $index) = @_;
        delete $$self{WRAP}[$index];
}

sub CLEAR {
        my $self = shift;
        @{$$self{WRAP}} = ();
}

sub PUSH {
        my $self = shift;
        push @{$$self{WRAP}}, map Tie::Filter::_filter($$self{STORE}, $_), @_;
}

sub POP {
        my $self = shift;
        Tie::Filter::_filter($$self{FETCH}, pop @{$$self{WRAP}});
}

sub SHIFT {
        my $self = shift;
        Tie::Filter::_filter($$self{FETCH}, shift @{$$self{WRAP}});
}

sub UNSHIFT {
        my $self = shift;
        unshift @{$$self{WRAP}}, map Tie::Filter::_filter($$self{STORE}, $_), @_;
}

sub SPLICE {
        my $self = shift;
        my $offset = shift;
        my $length = shift;
        printf "## splice(%04x,%04x) %d,%d\n", ( $offset, $length ) x 2;
        splice(@{$$self{WRAP}}, $offset, $length, @_);
}

sub UNTIE { }

sub DESTROY { }

=head1 SEE ALSO

L<perltie>, L<Tie::Filter>

=head1 AUTHOR

  Andrew Sterling Hanenkamp, <sterling@hanenkamp.com>

=head1 LICENSE AND COPYRIGHT

Copyright 2003 Andrew Sterling Hanenkamp. All Rights Reserved. This library is
free software; you can redistribute it and/or modify it under the same terms as
Perl itself.

=cut

1

1	#package Tie::Filter::Array;
2	package TieMem;
3
4	use 5.008;
5	use strict;
6	use warnings;
7
8	use Carp qw/confess/;
9	use base qw/Tie::Array/;
10
11	use Data::Dump qw/dump/;
12
13	our $VERSION = '1.02';
14
15	=head1 NAME
16
17	Tie::Filter::Array - Tie a facade around an array
18
19	=head1 DESCRIPTION
20
21	Don't use this package directly. Instead, see L<Tie::Filter>.
22
23	=cut
24
25	sub _read {
26	my ( $self, $index ) = @_;
27	my $value = $$self{WRAP}[$index];
28	confess "write undef value to $index" unless defined($value);
29	# printf "_read(%04x) = %2x %d\n", $index, $value, $value;
30	$self->{mem_acc}->( $index, 'read' );
31	return $value;
32	}
33
34	sub _write {
35	my ( $self, $index, $value ) = @_;
36	if ( $index >= 0x6000 && $index < 0x8000 ) {
37	$self->{vram}->( $index, $value );
38	}
39	confess "write undef value to $index" unless defined($value);
40	# printf "_write(%04x) = %2x %d\n", $index, $value, $value;
41	$self->{mem_acc}->( $index, 'write' );
42	$$self{WRAP}[$index] = $value;
43	}
44
45	my @ram = (0) x 65535;
46
47	sub TIEARRAY {
48	my %self;
49	my ($class, $args) = @_;
50	warn "tiemem",dump( $class, $args );
51	$self{WRAP} = \@ram;
52	foreach my $p ( qw/vram mem_acc/ ) {
53	$self{$p} = $args->{$p} \|\| die "no $p ?";
54	}
55	return bless \%self, $class;
56	}
57
58	sub FETCH {
59	my ($self, $index) = @_;
60	$self->_read($index);
61	}
62
63	sub STORE {
64	my ($self, $index, $value) = @_;
65	$self->_write( $index, $value );
66	}
67
68	sub FETCHSIZE {
69	my $self = shift;
70	scalar(@{$$self{WRAP}});
71	}
72
73	sub STORESIZE {
74	my ($self, $count) = @_;
75	$#{$$self{WRAP}} = $count - 1;
76	}
77
78	# TODO (?) Detect if the wrappee is tied and call it's EXTEND if it is,
79	# otherwise do nothing.
80	sub EXTEND { }
81
82	sub EXISTS {
83	my ($self, $index) = @_;
84	exists $$self{WRAP}[$index];
85	}
86
87	sub DELETE {
88	my ($self, $index) = @_;
89	delete $$self{WRAP}[$index];
90	}
91
92	sub CLEAR {
93	my $self = shift;
94	@{$$self{WRAP}} = ();
95	}
96
97	sub PUSH {
98	my $self = shift;
99	push @{$$self{WRAP}}, map Tie::Filter::_filter($$self{STORE}, $_), @_;
100	}
101
102	sub POP {
103	my $self = shift;
104	Tie::Filter::_filter($$self{FETCH}, pop @{$$self{WRAP}});
105	}
106
107	sub SHIFT {
108	my $self = shift;
109	Tie::Filter::_filter($$self{FETCH}, shift @{$$self{WRAP}});
110	}
111
112	sub UNSHIFT {
113	my $self = shift;
114	unshift @{$$self{WRAP}}, map Tie::Filter::_filter($$self{STORE}, $_), @_;
115	}
116
117	sub SPLICE {
118	my $self = shift;
119	my $offset = shift;
120	my $length = shift;
121	printf "## splice(%04x,%04x) %d,%d\n", ( $offset, $length ) x 2;
122	splice(@{$$self{WRAP}}, $offset, $length, @_);
123	}
124
125	sub UNTIE { }
126
127	sub DESTROY { }
128
129	=head1 SEE ALSO
130
131	L<perltie>, L<Tie::Filter>
132
133	=head1 AUTHOR
134
135	Andrew Sterling Hanenkamp, <sterling@hanenkamp.com>
136
137	=head1 LICENSE AND COPYRIGHT
138
139	Copyright 2003 Andrew Sterling Hanenkamp. All Rights Reserved. This library is
140	free software; you can redistribute it and/or modify it under the same terms as
141	Perl itself.
142
143	=cut
144
145	1
146