File Coverage

blib/lib/Acme/6502/Tube.pm
Criterion Covered Total %
statement 27 165 16.3
branch 0 50 0.0
condition 0 8 0.0
subroutine 9 24 37.5
pod 2 2 100.0
total 38 249 15.2


line stmt bran cond sub pod time code
1             package Acme::6502::Tube;
2              
3 1     1   859 use warnings;
  1         2  
  1         36  
4 1     1   6 use strict;
  1         3  
  1         31  
5 1     1   6 use Carp;
  1         2  
  1         77  
6 1     1   5102 use Time::HiRes qw(time);
  1         11681  
  1         9  
7 1     1   2012 use Term::ReadKey ();
  1         14317  
  1         41  
8 1     1   14 use base qw(Acme::6502);
  1         2  
  1         183  
9              
10             our $VERSION = '0.77';
11              
12 1     1   7 use constant ERROR => 0xF800;
  1         1  
  1         110  
13              
14             use constant {
15 1         87 PAGE => 0x0800,
16             HIMEM => 0x8000
17 1     1   6 };
  1         2  
18              
19             use constant {
20 1         2682 OSRDRM => 0xFFB9,
21             OSEVEN => 0xFFBF,
22             GSINIT => 0xFFC2,
23             GSREAD => 0xFFC5,
24             NVWRCH => 0xFFC8,
25             NVRDCH => 0xFFCB,
26             OSFIND => 0xFFCE,
27             OSGBPB => 0xFFD1,
28             OSBPUT => 0xFFD4,
29             OSBGET => 0xFFD7,
30             OSARGS => 0xFFDA,
31             OSFILE => 0xFFDD,
32             OSASCI => 0xFFE3,
33             OSNEWL => 0xFFE7,
34             OSWRCH => 0xFFEE,
35             OSRDCH => 0xFFE0,
36             OSWORD => 0xFFF1,
37             OSBYTE => 0xFFF4,
38             OSCLI => 0xFFF7
39 1     1   6 };
  1         3  
40              
41             sub _BUILD {
42 0     0     my ( $self, $args ) = @_;
43              
44 0           $self->SUPER::_BUILD( $args );
45              
46 0           $self->{ time_base } = time();
47              
48             # Inline OSASCI code
49 0           $self->poke_code( OSASCI,
50             0xC9, 0x0D, # CMP #&0D
51             0xD0, 0x07, # BNE +7
52             0xA9, 0x0A, # LDA #&0A
53             0x20, 0xEE, 0xFF, # JSR &FFEE
54             0xA9, 0x0D # LDA #&0D
55             );
56              
57             # BRK handler. The interrupt handling is bogus - so don't
58             # generate any interrupts before fixing it :)
59 0           $self->poke_code(
60             0xFF00, 0x85, 0xFC, 0x68, 0x58, 0x29, 0x10, 0xF0,
61             0x17, 0x8A, 0x48, 0xBA, 0x38, 0xBD, 0x02, 0x01,
62             0xE9, 0x01, 0x85, 0xFD, 0xBD, 0x03, 0x01, 0xE9,
63             0x00, 0x85, 0xFE, 0x68, 0xAA, 0x6C, 0x02, 0x02,
64             0x6C, 0x04, 0x02
65             );
66              
67 0           $self->write_16( $self->BREAK, 0xFF00 );
68              
69 0           $self->make_vector( 'OSCLI', 0x208, \&_oscli );
70 0           $self->make_vector( 'OSBYTE', 0x20A, \&_osbyte );
71 0           $self->make_vector( 'OSWORD', 0x20C, \&_osword );
72 0           $self->make_vector( 'OSWRCH', 0x20E, \&_oswrch );
73 0           $self->make_vector( 'OSRDCH', 0x210, \&_osrdch );
74 0           $self->make_vector( 'OSFILE', 0x212, \&_osfile );
75 0           $self->make_vector( 'OSARGS', 0x214, \&_osargs );
76 0           $self->make_vector( 'OSBGET', 0x216, \&_osbget );
77 0           $self->make_vector( 'OSBPUT', 0x218, \&_osbput );
78 0           $self->make_vector( 'OSGBPB', 0x21A, \&_osgbpb );
79 0           $self->make_vector( 'OSFIND', 0x21C, \&_osfind );
80              
81 0           $self->set_jumptab( 0xFA00 );
82             }
83              
84             sub _oscli {
85 0     0     my $self = shift;
86 0           my $blk = $self->get_xy();
87 0           my $cmd = '';
88 0           CH: for ( ;; ) {
89 0           my $ch = $self->read_8( $blk++ );
90 0 0         last CH if $ch < 0x20;
91 0           $cmd .= chr( $ch );
92             }
93 0           $cmd =~ s/^[\s\*]+//g;
94 0 0         if ( lc( $cmd ) eq 'quit' ) {
95 0           exit;
96             }
97             else {
98 0           system( $cmd );
99             }
100             }
101              
102             sub _osbyte {
103 0     0     my $self = shift;
104 0           my $a = $self->get_a();
105 0 0         if ( $a == 0x7E ) {
    0          
    0          
    0          
    0          
106             # Ack escape
107 0           $self->write_8( 0xFF, 0 );
108 0           $self->set_x( 0xFF );
109             }
110             elsif ( $a == 0x82 ) {
111             # Read m/c high order address
112 0           $self->set_xy( 0 );
113             }
114             elsif ( $a == 0x83 ) {
115             # Read OSHWM (PAGE)
116 0           $self->set_xy( PAGE );
117             }
118             elsif ( $a == 0x84 ) {
119             # Read HIMEM
120 0           $self->set_xy( HIMEM );
121             }
122             elsif ( $a == 0xDA ) {
123 0           $self->set_xy( 0x0900 );
124             }
125             else {
126 0           die sprintf( "OSBYTE %02x not handled\n", $a );
127             }
128             }
129              
130             sub _set_escape {
131 0     0     my $self = shift;
132 0           $self->write_8( 0xFF, 0xFF );
133             }
134              
135             sub _osword {
136 0     0     my $self = shift;
137 0           my $a = $self->get_a();
138 0           my $blk = $self->get_xy();
139              
140 0 0         if ( $a == 0x00 ) {
    0          
    0          
141             # Command line input
142 0           my $buf = $self->read_16( $blk );
143 0           my $len = $self->read_8( $blk + 2 );
144 0           my $min = $self->read_8( $blk + 3 );
145 0           my $max = $self->read_8( $blk + 4 );
146 0           my $y = 0;
147 0 0         if ( defined( my $in = <> ) ) {
148 0           my @c = map ord, split //, $in;
149 0   0       while ( @c && $len-- > 1 ) {
150 0           my $c = shift @c;
151 0 0 0       if ( $c >= $min && $c <= $max ) {
152 0           $self->write_8( $buf + $y++, $c );
153             }
154             }
155 0           $self->write_8( $buf + $y++, 0x0D );
156 0           $self->set_y( $y );
157 0           $self->set_p( $self->get_p() & ~$self->C );
158             }
159             else {
160             # Escape I suppose...
161 0           $self->set_p( $self->get_p() | $self->C );
162             }
163             }
164             elsif ( $a == 0x01 ) {
165             # Read clock
166 0           my $now = int( ( time() - $self->{ time_base } ) * 100 );
167 0           $self->write_32( $blk, $now );
168 0           $self->write_8( $blk + 4, 0 );
169             }
170             elsif ( $a == 0x02 ) {
171             # Set clock
172 0           my $tm = $self->read_32( $blk );
173 0           $self->{ time_base } = time() - ( $tm * 100 );
174             }
175             else {
176 0           die sprintf( "OSWORD %02x not handled\n", $a );
177             }
178             }
179              
180             sub _oswrch {
181 0     0     my $self = shift;
182 0           printf( "%c", $self->get_a() );
183             }
184              
185             sub _osrdch {
186 0     0     my $self = shift;
187 0           Term::ReadKey::ReadMode( 4 );
188 0           eval {
189 0           my $k = ord( Term::ReadKey::ReadKey( 0 ) );
190 0 0         $k = 0x0D if $k == 0x0A;
191 0           $self->set_a( $k );
192 0 0         if ( $k == 27 ) {
193 0           $self->set_escape;
194 0           $self->set_p( $self->get_p() | $self->C );
195             }
196             else {
197 0           $self->set_p( $self->get_p() & ~$self->C );
198             }
199             };
200 0           Term::ReadKey::ReadMode( 0 );
201 0 0         die $@ if $@;
202             }
203              
204             sub _osfile {
205 0     0     my $self = shift;
206 0           my $a = $self->get_a();
207 0           my $blk = $self->get_xy();
208 0           my $name = $self->read_str( $self->read_16( $blk ) );
209 0           my $load = $self->read_32( $blk + 2 );
210 0           my $exec = $self->read_32( $blk + 6 );
211 0           my $start = $self->read_32( $blk + 10 );
212 0           my $end = $self->read_32( $blk + 14 );
213              
214             # printf("%-20s %08x %08x %08x %08x\n", $name, $load, $exec, $start, $end);
215 0 0         if ( $a == 0x00 ) {
    0          
216             # Save
217 0 0         open my $fh, '>', $name or die "Can't write $name\n";
218 0           binmode $fh;
219 0           my $buf = $self->read_chunk( $start, $end );
220 0 0         syswrite $fh, $buf or die "Error writing $name\n";
221 0           $self->set_a( 1 );
222             }
223             elsif ( $a == 0xFF ) {
224             # Load
225 0 0         if ( -f $name ) {
    0          
226 0 0         open my $fh, '<', $name or die "Can't read $name\n";
227 0           binmode $fh;
228 0           my $len = -s $fh;
229 0 0         sysread $fh, my $buf, $len or die "Error reading $name\n";
230 0 0         $load = PAGE if $exec & 0xFF;
231 0           $self->write_chunk( $load, $buf );
232 0           $self->write_32( $blk + 2, $load );
233 0           $self->write_32( $blk + 6, 0x00008023 );
234 0           $self->write_32( $blk + 10, $len );
235 0           $self->write_32( $blk + 14, 0x00000000 );
236 0           $self->set_a( 1 );
237             }
238             elsif ( -d $name ) {
239 0           $self->set_a( 2 );
240             }
241             else {
242 0           $self->set_a( 0 );
243             }
244             }
245             else {
246 0           die sprintf( "OSFILE %02x not handled\n", $a );
247             }
248             }
249              
250             sub _osargs {
251 0     0     die "OSARGS not handled\n";
252             }
253              
254             sub _osbget {
255 0     0     die "OSBGET not handled\n";
256             }
257              
258             sub _osbput {
259 0     0     die "OSBPUT not handled\n";
260             }
261              
262             sub _osgbpb {
263 0     0     die "OSGBPB not handled\n";
264             }
265              
266             sub _osfind {
267 0     0     die "OSFIND not handled\n";
268             }
269              
270             sub make_vector {
271 0     0 1   my( $self, $name, $vec, $code ) = @_;
272              
273 0           my $addr = $self->$name;
274 0           my $vecno = scalar @{ $self->{ os } };
  0            
275 0           push @{ $self->{ os } }, [ $code, $name ];
  0            
276              
277 0           $self->SUPER::make_vector( $addr, $vec, $vecno );
278             }
279              
280             sub call_os {
281 0     0 1   my $self = shift;
282 0           my $vecno = shift;
283              
284 0           eval {
285 0   0       my $call = $self->{ os }->[ $vecno ] || die "Bad OS call $vecno\n";
286 0           $call->[ 0 ]->( $self );
287             };
288              
289 0 0         if ( $@ ) {
290 0           my $err = $@;
291 0           $self->write_16( ERROR, 0x7F00 );
292 0           $err =~ s/\s+/ /;
293 0           $err =~ s/^\s+//;
294 0           $err =~ s/\s+$//;
295 0           warn $err;
296 0           my $ep = ERROR + 2;
297 0           for ( map ord, split //, $err ) {
298 0           $self->write_8( $ep++, $_ );
299             }
300 0           $self->write_8( $ep++, 0x00 );
301 0           $self->set_pc( ERROR );
302             }
303             }
304              
305             1;
306             __END__