viewvc.cgi/VRac/Orao.pm

package Orao;

use warnings;
use strict;

use Carp qw/confess/;
use lib './lib';
#use Time::HiRes qw(time);
use File::Slurp;
use Data::Dump qw/dump/;
use List::Util qw/first/;
use M6502;

use base qw(Class::Accessor M6502 Screen Prefs);
__PACKAGE__->mk_accessors(qw(run_for));

=head1 NAME

Orao - Orao emulator

=head1 VERSION

Version 0.02

=cut

our $VERSION = '0.02';

=head1 SUMMARY

Emulator or Orao 8-bit 6502 machine popular in Croatia

=cut

my @kbd_ports = (
    0x87FC,0x87FD,0x87FA,0x87FB,0x87F6,0x87F7,
    0x87EE,0x87EF,0x87DE,0x87DF,0x87BE,0x87BF,
    0x877E,0x877F,0x86FE,0x86FF,0x85FE,0x85FF,
    0x83FE,0x83FF,
);

=head2 boot

Start emulator, open L<Screen>, load initial ROM images, and render memory

  my $orao = Orao->new({});
  $orao->boot;

=cut

our $orao;

select(STDERR); $| = 1;

sub boot {
        my $self = shift;
        warn "Orao calling upstream init\n";
        $self->SUPER::init( $self, @_ );

        warn "Orao $Orao::VERSION emulation starting\n";

        $self->open_screen;
        $self->load_rom({
                0x1000 => 'dump/SCRINV.BIN',
                # should be 0x6000, but oraoemu has 2 byte prefix
                0x5FFE => 'dump/screen.dmp',
                0xC000 => 'rom/BAS12.ROM',
                0xE000 => 'rom/CRT12.ROM',
        });

#       $PC = 0xDD11;   # BC
#       $PC = 0xC274;   # MC

        $PC = 0xff89;

        $orao = $self;

#       $self->prompt( 0x1000 );

        my ( $trace, $debug ) = ( $self->trace, $self->debug );
        $self->trace( 0 );
        $self->debug( 0 );

        $self->render( @mem[ 0x6000 .. 0x7fff ] );

        if ( $self->show_mem ) {

                warn "rendering memory map\n";

                $self->render_mem( @mem );

                my @mmap = (
                        0x0000, 0x03FF, 'nulti blok',
                        0x0400, 0x5FFF, 'korisnièki RAM (23K)',
                        0x6000, 0x7FFF, 'video RAM',
                        0x8000, 0x9FFF, 'sistemske lokacije',
                        0xA000, 0xAFFF, 'ekstenzija',
                        0xB000, 0xBFFF, 'DOS',
                        0xC000, 0xDFFF, 'BASIC ROM',
                        0xE000, 0xFFFF, 'sistemski ROM',
                );

        } else {

                warn "rendering video memory\n";
                $self->render( @mem[ 0x6000 .. 0x7fff ] );
        
        }
        $self->sync;
        $self->trace( $trace );
        $self->debug( $debug );

        #( $A, $P, $X, $Y, $S, $IPeriod ) = ( 1, 2, 3, 4, 5, 6 );

        warn "Orao boot finished",
                $self->trace ? ' trace' : '',
                $self->debug ? ' debug' : '',
                "\n";

        M6502::reset();

}

=head2 load_rom

called to init memory and load initial rom images

  $orao->load_rom;

=cut

sub load_rom {
    my ($self, $loaded_files) = @_;

    #my $time_base = time();

        foreach my $addr ( sort keys %$loaded_files ) {
                my $path = $loaded_files->{$addr};
                $self->load_oraoemu( $path, $addr );
        }
}

# write chunk directly into memory, updateing vram if needed
sub _write_chunk {
        my $self = shift;
        my ( $addr, $chunk ) = @_;
        $self->write_chunk( $addr, $chunk );
        my $end = $addr + length($chunk);
        my ( $f, $t ) = ( 0x6000, 0x7fff );

        if ( $end < $f || $addr >= $t ) {
                warn "skip vram update\n";
                return;
        };

        $f = $addr if ( $addr > $f );
        $t = $end if ( $end < $t );

        warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
#       foreach my $a ( $f .. $t ) {
#               $self->vram( $a - 0x6000 , $mem[ $a ] );
#       }
        $self->render( @mem[ 0x6000 .. 0x7fff ] );
        $self->render_mem( @mem ) if $self->show_mem;
}

=head2 load_oraoemu

Load binary files, ROM images and Orao Emulator files

  $orao->load_oraoemu( '/path/to/file', 0x1000 );

Returns true on success.

=cut

sub load_oraoemu {
        my $self = shift;
        my ( $path, $addr ) = @_;

        if ( ! -e $path ) {
                warn "ERROR: file $path doesn't exist\n";
                return;
        }

        my $size = -s $path || confess "no size for $path: $!";

        my $buff = read_file( $path );

        if ( $size == 65538 ) {
                $addr = 0;
                warn sprintf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
                $self->_write_chunk( $addr, substr($buff,2) );
                return 1;
        } elsif ( $size == 32800 ) {
                $addr = 0;
                warn sprintf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
                $self->_write_chunk( $addr, substr($buff,0x20) );
                return 1;
        }
        printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
        $self->_write_chunk( $addr, $buff );
        return 1;

        my $chunk;

        my $pos = 0;

        while ( my $long = substr($buff,$pos,4) ) {
                my @b = split(//, $long, 4);
                $chunk .=
                        ( $b[3] || '' ) .
                        ( $b[2] || '' ) .
                        ( $b[1] || '' ) .
                        ( $b[0] || '' );
                $pos += 4;
        }

        $self->_write_chunk( $addr, $chunk );

        return 1;
};

=head2 save_dump

  $orao->save_dump( 'filename', $from, $to );

=cut

sub save_dump {
        my $self = shift;

        my ( $path, $from, $to ) = @_;

        $from ||= 0;
        $to ||= 0xffff;

        open(my $fh, '>', $path) || die "can't open $path: $!";
        print $fh $self->read_chunk( $from, $to );
        close($fh);

        my $size = -s $path;
        warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;
}

=head2 hexdump

  $orao->hexdump( $address );

=cut

sub hexdump {
        my $self = shift;
        my $a = shift;
        return sprintf(" %04x %s\n", $a,
                join(" ",
                        map {
                                if ( defined($_) ) {
                                        sprintf( "%02x", $_ )
                                } else {
                                        '  '
                                }
                        } @mem[ $a .. $a+8 ]
                )
        );
}

=head1 Memory management

Orao implements all I/O using mmap addresses. This was main reason why
L<Acme::6502> was just too slow to handle it.

=cut

=head2 read

Read from memory

  $byte = read( $address );

=cut

sub read {
        my $self = shift;
        my ($addr) = @_;
        my $byte = $mem[$addr];
        warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;

        # keyboard

        if ( first { $addr == $_ } @kbd_ports ) {
                warn sprintf("keyboard port: %04x\n",$addr);
        } elsif ( $addr == 0x87fc ) {
                warn "0x87fc - arrows/back\n";
=for pascal
                if VKey=VK_RIGHT then Result:=16;
                if VKey=VK_DOWN then Result:=128;
                if VKey=VK_UP then Result:=192;
                if VKey=VK_LEFT then Result:=224;
                if Ord(KeyPressed)=VK_BACK then Result:=224;
=cut
        } elsif ( $addr == 0x87fd ) {
                warn "0x87fd - enter\n";
=for pascal
    if KeyPressed=Chr(13) then begin
      Mem[$FC]:=13;
      Result:=0;
    end;
=cut
        } elsif ( $addr == 0x87fa ) {
                warn "0x87fa = F1 - F4\n";
=for pascal
    if VKey=VK_F4 then Result:=16;
    if VKey=VK_F3 then Result:=128;
    if VKey=VK_F2 then Result:=192;
    if VKey=VK_F1 then Result:=224;
=cut
        } elsif ( $addr == 0x87fb ) {
                warn "0x87fb\n";
=for pascal
    if KeyPressed=Chr(32) then Result:=32;
    if KeyPressed='"' then Result:=16;
    if KeyPressed='!' then Result:=16;
    if KeyPressed='$' then Result:=16;
    if KeyPressed='%' then Result:=16;
    if KeyPressed='&' then Result:=16;
    if KeyPressed='(' then Result:=16;
    if KeyPressed=')' then Result:=16;
    if KeyPressed='=' then Result:=16;
    if KeyPressed='#' then Result:=16;
    if KeyPressed='+' then Result:=16;
    if KeyPressed='*' then Result:=16;
    if KeyPressed='?' then Result:=16;
    if KeyPressed='<' then Result:=16;
    if KeyPressed='>' then Result:=16;
    if VKey=191 then Result:=16;
=cut
        }

        $self->mmap_pixel( $addr, 0, $byte, 0 );
        return $byte;
}

=head2 write

Write into emory

  write( $address, $byte );

=cut

sub write {
        my $self = shift;
        my ($addr,$byte) = @_;
        warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;

        if ( $addr >= 0x6000 && $addr < 0x8000 ) {
                $self->vram( $addr - 0x6000 , $byte );
        }

        if ( $addr == 0x8800 ) {
                warn sprintf "sound ignored: %x\n", $byte;
        }

        if ( $addr > 0xafff ) {
                warn sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
                return;
        }

        $self->mmap_pixel( $addr, $byte, 0, 0 );

        $mem[$addr] = $byte;
        return;
}

=head1 Command Line

Command-line debugging intrerface is implemented for communication with
emulated device

=head2 prompt

  my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );

=cut

my $last = 'r 1';

sub prompt {
        my $self = shift;
        $self->app->sync;
        my $a = shift;
        print STDERR $self->hexdump( $a ),
                $last ? "[$last] " : '',
                "> ";
        my $in = <STDIN>;
        chomp($in);
        warn "## prompt got: $in\n" if $self->debug;
        $in ||= $last;
        $last = $in;
        return ( $in, split(/\s+/, $in) ) if $in;
}

=head2 cli

  $orao->cli();

=cut

my $show_R = 0;

sub cli {
        my $self = shift;
        my $a = $PC || confess "no pc?"; 
        warn $self->dump_R() if $show_R;
        while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
                my $c = shift @v;
                next unless defined($c);
                my $v = shift @v;
                $v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
                @v = map { hex($_) } @v;
                printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v || 'undef'), join(",",@v) if $self->debug;
                if ( $c =~ m/^[qx]/i ) {
                        exit;
                } elsif ( $c eq '?' ) {
                        my $t = $self->trace ? 'on' : 'off' ;
                        my $d = $self->debug ? 'on' : 'off' ;
                        warn <<__USAGE__;
Usage:

x|q\t\texit
e 6000 6010\tdump memory, +/- to walk forward/backward
m 1000 ff 00\tput ff 00 on 1000
j|u 1000\t\tjump (change pc)
r 42\t\trun 42 instruction opcodes
t\t\ttrace [$t]
d\t\tdebug [$d]

__USAGE__
                        warn $self->dump_R;
                } elsif ( $c =~ m/^e/i ) {
                        $a = $v if defined($v);
                        my $to = shift @v;
                        $to = $a + 32 if ( ! $to || $to <= $a );
                        $to = 0xffff if ( $to > 0xffff );
                        my $lines = int( ($to - $a + 8) / 8 );
                        printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
                        while ( --$lines ) {
                                print $self->hexdump( $a );
                                $a += 8;
                        }
                        $last = '+';
                        $show_R = 0;
                } elsif ( $c =~ m/^\+/ ) {
                        $a += 8;
                        $show_R = 0;
                } elsif ( $c =~ m/^\-/ ) {
                        $a -= 8;
                        $show_R = 0;
                } elsif ( $c =~ m/^m/i ) {
                        $a = $v if defined($v);
                        $self->poke_code( $a, @v );
                        printf "poke %d bytes at %04x\n", $#v + 1, $a;
                        $last = '+';
                        $show_R = 0;
                } elsif ( $c =~ m/^l/i ) {
                        my $to = shift @v || 0x1000;
                        $a = $to;
                        $self->load_oraoemu( $v, $a );
                        $last = '';
                } elsif ( $c =~ m/^s/i ) {
                        $self->save_dump( $v || 'mem.dump', @v );
                        $last = '';
                } elsif ( $c =~ m/^r/i ) {
                        $run_for = $v || 1;
                        print "run_for $run_for instructions\n";
                        $show_R = 1;
                        last;
                } elsif ( $c =~ m/^(u|j)/ ) {
                        my $to = $v || $a;
                        printf "set pc to %04x\n", $to;
                        $PC = $to;      # remember for restart
                        $run_for = 1;
                        $last = "r $run_for";
                        $show_R = 1;
                        last;
                } elsif ( $c =~ m/^t/ ) {
                        $self->trace( not $self->trace );
                        print "trace ", $self->trace ? 'on' : 'off', "\n";
                        $last = '';
                } elsif ( $c =~ m/^d/ ) {
                        $self->debug( not $self->debug );
                        print "debug ", $self->debug ? 'on' : 'off', "\n";
                        $last = '';
                } else {
                        warn "# ignored $line\n" if ($line);
                        $last = '';
                }
        }

}

=head1 AUTHOR

Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>

=head1 BUGS

=head1 ACKNOWLEDGEMENTS

See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all
info about this machine (and even hardware implementation from 2007).

=head1 COPYRIGHT & LICENSE

Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1; # End of Orao
1	dpavlin	29	package Orao;
2
3			use warnings;
4			use strict;
5
6	dpavlin	56	use Carp qw/confess/;
7	dpavlin	29	use lib './lib';
8			#use Time::HiRes qw(time);
9			use File::Slurp;
10	dpavlin	32	use Data::Dump qw/dump/;
11	dpavlin	78	use List::Util qw/first/;
12	dpavlin	34	use M6502;
13	dpavlin	29
14	dpavlin	56	use base qw(Class::Accessor M6502 Screen Prefs);
15			__PACKAGE__->mk_accessors(qw(run_for));
16	dpavlin	29
17			=head1 NAME
18
19			Orao - Orao emulator
20
21			=head1 VERSION
22
23			Version 0.02
24
25			=cut
26
27			our $VERSION = '0.02';
28
29			=head1 SUMMARY
30
31			Emulator or Orao 8-bit 6502 machine popular in Croatia
32
33			=cut
34
35	dpavlin	78	my @kbd_ports = (
36			0x87FC,0x87FD,0x87FA,0x87FB,0x87F6,0x87F7,
37			0x87EE,0x87EF,0x87DE,0x87DF,0x87BE,0x87BF,
38			0x877E,0x877F,0x86FE,0x86FF,0x85FE,0x85FF,
39			0x83FE,0x83FF,
40			);
41
42	dpavlin	82	=head2 boot
43	dpavlin	30
44	dpavlin	56	Start emulator, open L<Screen>, load initial ROM images, and render memory
45	dpavlin	30
46	dpavlin	82	my $orao = Orao->new({});
47			$orao->boot;
48
49	dpavlin	30	=cut
50
51	dpavlin	32	our $orao;
52
53	dpavlin	42	select(STDERR); $\| = 1;
54
55	dpavlin	82	sub boot {
56	dpavlin	30	my $self = shift;
57	dpavlin	34	warn "Orao calling upstream init\n";
58	dpavlin	33	$self->SUPER::init( $self, @_ );
59	dpavlin	30
60	dpavlin	56	warn "Orao $Orao::VERSION emulation starting\n";
61	dpavlin	30
62			$self->open_screen;
63	dpavlin	33	$self->load_rom({
64			0x1000 => 'dump/SCRINV.BIN',
65	dpavlin	76	# should be 0x6000, but oraoemu has 2 byte prefix
66			0x5FFE => 'dump/screen.dmp',
67	dpavlin	33	0xC000 => 'rom/BAS12.ROM',
68			0xE000 => 'rom/CRT12.ROM',
69			});
70	dpavlin	32
71	dpavlin	73	# $PC = 0xDD11; # BC
72	dpavlin	46	# $PC = 0xC274; # MC
73	dpavlin	35
74	dpavlin	78	$PC = 0xff89;
75
76	dpavlin	32	$orao = $self;
77
78	dpavlin	33	# $self->prompt( 0x1000 );
79
80	dpavlin	49	my ( $trace, $debug ) = ( $self->trace, $self->debug );
81	dpavlin	38	$self->trace( 0 );
82	dpavlin	49	$self->debug( 0 );
83	dpavlin	33
84	dpavlin	73	$self->render( @mem[ 0x6000 .. 0x7fff ] );
85
86	dpavlin	38	if ( $self->show_mem ) {
87	dpavlin	33
88	dpavlin	38	warn "rendering memory map\n";
89
90	dpavlin	76	$self->render_mem( @mem );
91
92	dpavlin	38	my @mmap = (
93			0x0000, 0x03FF, 'nulti blok',
94			0x0400, 0x5FFF, 'korisnièki RAM (23K)',
95			0x6000, 0x7FFF, 'video RAM',
96			0x8000, 0x9FFF, 'sistemske lokacije',
97			0xA000, 0xAFFF, 'ekstenzija',
98			0xB000, 0xBFFF, 'DOS',
99			0xC000, 0xDFFF, 'BASIC ROM',
100			0xE000, 0xFFFF, 'sistemski ROM',
101			);
102
103			} else {
104
105			warn "rendering video memory\n";
106	dpavlin	73	$self->render( @mem[ 0x6000 .. 0x7fff ] );
107	dpavlin	38
108	dpavlin	33	}
109	dpavlin	38	$self->sync;
110			$self->trace( $trace );
111	dpavlin	49	$self->debug( $debug );
112	dpavlin	33
113	dpavlin	39	#( $A, $P, $X, $Y, $S, $IPeriod ) = ( 1, 2, 3, 4, 5, 6 );
114	dpavlin	34
115	dpavlin	82	warn "Orao boot finished",
116	dpavlin	49	$self->trace ? ' trace' : '',
117			$self->debug ? ' debug' : '',
118			"\n";
119	dpavlin	38
120	dpavlin	82	M6502::reset();
121
122	dpavlin	30	}
123
124	dpavlin	29	=head2 load_rom
125
126			called to init memory and load initial rom images
127
128			$orao->load_rom;
129
130			=cut
131
132			sub load_rom {
133	dpavlin	33	my ($self, $loaded_files) = @_;
134	dpavlin	29
135			#my $time_base = time();
136
137			foreach my $addr ( sort keys %$loaded_files ) {
138			my $path = $loaded_files->{$addr};
139			$self->load_oraoemu( $path, $addr );
140			}
141			}
142
143	dpavlin	61	# write chunk directly into memory, updateing vram if needed
144	dpavlin	46	sub _write_chunk {
145			my $self = shift;
146			my ( $addr, $chunk ) = @_;
147			$self->write_chunk( $addr, $chunk );
148			my $end = $addr + length($chunk);
149			my ( $f, $t ) = ( 0x6000, 0x7fff );
150
151			if ( $end < $f \|\| $addr >= $t ) {
152			warn "skip vram update\n";
153			return;
154			};
155
156			$f = $addr if ( $addr > $f );
157			$t = $end if ( $end < $t );
158
159			warn sprintf("refresh video ram %04x-%04x\n", $f, $t);
160	dpavlin	73	# foreach my $a ( $f .. $t ) {
161			# $self->vram( $a - 0x6000 , $mem[ $a ] );
162			# }
163			$self->render( @mem[ 0x6000 .. 0x7fff ] );
164	dpavlin	77	$self->render_mem( @mem ) if $self->show_mem;
165	dpavlin	46	}
166
167	dpavlin	61	=head2 load_oraoemu
168
169			Load binary files, ROM images and Orao Emulator files
170
171			$orao->load_oraoemu( '/path/to/file', 0x1000 );
172
173			Returns true on success.
174
175			=cut
176
177	dpavlin	29	sub load_oraoemu {
178			my $self = shift;
179			my ( $path, $addr ) = @_;
180
181	dpavlin	61	if ( ! -e $path ) {
182			warn "ERROR: file $path doesn't exist\n";
183			return;
184			}
185
186	dpavlin	31	my $size = -s $path \|\| confess "no size for $path: $!";
187	dpavlin	29
188			my $buff = read_file( $path );
189
190			if ( $size == 65538 ) {
191			$addr = 0;
192	dpavlin	33	warn sprintf "loading oraoemu 64k dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
193	dpavlin	46	$self->_write_chunk( $addr, substr($buff,2) );
194	dpavlin	61	return 1;
195	dpavlin	29	} elsif ( $size == 32800 ) {
196			$addr = 0;
197	dpavlin	33	warn sprintf "loading oraoemu 1.3 dump %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
198	dpavlin	46	$self->_write_chunk( $addr, substr($buff,0x20) );
199	dpavlin	61	return 1;
200	dpavlin	29	}
201	dpavlin	33	printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
202	dpavlin	61	$self->_write_chunk( $addr, $buff );
203			return 1;
204	dpavlin	29
205			my $chunk;
206
207			my $pos = 0;
208
209			while ( my $long = substr($buff,$pos,4) ) {
210			my @b = split(//, $long, 4);
211			$chunk .=
212			( $b[3] \|\| '' ) .
213			( $b[2] \|\| '' ) .
214			( $b[1] \|\| '' ) .
215			( $b[0] \|\| '' );
216			$pos += 4;
217			}
218
219	dpavlin	46	$self->_write_chunk( $addr, $chunk );
220	dpavlin	29
221	dpavlin	61	return 1;
222	dpavlin	29	};
223
224			=head2 save_dump
225
226			$orao->save_dump( 'filename', $from, $to );
227
228			=cut
229
230			sub save_dump {
231			my $self = shift;
232
233			my ( $path, $from, $to ) = @_;
234
235			$from \|\|= 0;
236			$to \|\|= 0xffff;
237
238			open(my $fh, '>', $path) \|\| die "can't open $path: $!";
239			print $fh $self->read_chunk( $from, $to );
240			close($fh);
241
242			my $size = -s $path;
243	dpavlin	32	warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;
244	dpavlin	29	}
245
246			=head2 hexdump
247
248			$orao->hexdump( $address );
249
250			=cut
251
252			sub hexdump {
253			my $self = shift;
254			my $a = shift;
255			return sprintf(" %04x %s\n", $a,
256			join(" ",
257			map {
258	dpavlin	71	if ( defined($_) ) {
259			sprintf( "%02x", $_ )
260			} else {
261			' '
262			}
263	dpavlin	47	} @mem[ $a .. $a+8 ]
264	dpavlin	29	)
265			);
266			}
267
268	dpavlin	32	=head1 Memory management
269	dpavlin	30
270	dpavlin	32	Orao implements all I/O using mmap addresses. This was main reason why
271			L<Acme::6502> was just too slow to handle it.
272
273			=cut
274
275			=head2 read
276
277			Read from memory
278
279			$byte = read( $address );
280
281			=cut
282
283			sub read {
284	dpavlin	33	my $self = shift;
285	dpavlin	32	my ($addr) = @_;
286			my $byte = $mem[$addr];
287	dpavlin	41	warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
288	dpavlin	78
289			# keyboard
290
291			if ( first { $addr == $_ } @kbd_ports ) {
292			warn sprintf("keyboard port: %04x\n",$addr);
293			} elsif ( $addr == 0x87fc ) {
294			warn "0x87fc - arrows/back\n";
295			=for pascal
296			if VKey=VK_RIGHT then Result:=16;
297			if VKey=VK_DOWN then Result:=128;
298			if VKey=VK_UP then Result:=192;
299			if VKey=VK_LEFT then Result:=224;
300			if Ord(KeyPressed)=VK_BACK then Result:=224;
301			=cut
302			} elsif ( $addr == 0x87fd ) {
303			warn "0x87fd - enter\n";
304			=for pascal
305			if KeyPressed=Chr(13) then begin
306			Mem[$FC]:=13;
307			Result:=0;
308			end;
309			=cut
310			} elsif ( $addr == 0x87fa ) {
311			warn "0x87fa = F1 - F4\n";
312			=for pascal
313			if VKey=VK_F4 then Result:=16;
314			if VKey=VK_F3 then Result:=128;
315			if VKey=VK_F2 then Result:=192;
316			if VKey=VK_F1 then Result:=224;
317			=cut
318			} elsif ( $addr == 0x87fb ) {
319			warn "0x87fb\n";
320			=for pascal
321			if KeyPressed=Chr(32) then Result:=32;
322			if KeyPressed='"' then Result:=16;
323			if KeyPressed='!' then Result:=16;
324			if KeyPressed='$' then Result:=16;
325			if KeyPressed='%' then Result:=16;
326			if KeyPressed='&' then Result:=16;
327			if KeyPressed='(' then Result:=16;
328			if KeyPressed=')' then Result:=16;
329			if KeyPressed='=' then Result:=16;
330			if KeyPressed='#' then Result:=16;
331			if KeyPressed='+' then Result:=16;
332			if KeyPressed='*' then Result:=16;
333			if KeyPressed='?' then Result:=16;
334			if KeyPressed='<' then Result:=16;
335			if KeyPressed='>' then Result:=16;
336			if VKey=191 then Result:=16;
337			=cut
338			}
339
340	dpavlin	33	$self->mmap_pixel( $addr, 0, $byte, 0 );
341	dpavlin	32	return $byte;
342			}
343
344			=head2 write
345
346			Write into emory
347
348			write( $address, $byte );
349
350			=cut
351
352			sub write {
353	dpavlin	33	my $self = shift;
354	dpavlin	32	my ($addr,$byte) = @_;
355	dpavlin	41	warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
356	dpavlin	32
357			if ( $addr >= 0x6000 && $addr < 0x8000 ) {
358			$self->vram( $addr - 0x6000 , $byte );
359			}
360
361			if ( $addr == 0x8800 ) {
362			warn sprintf "sound ignored: %x\n", $byte;
363			}
364
365	dpavlin	52	if ( $addr > 0xafff ) {
366	dpavlin	65	warn sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
367			return;
368	dpavlin	52	}
369
370	dpavlin	33	$self->mmap_pixel( $addr, $byte, 0, 0 );
371	dpavlin	32
372			$mem[$addr] = $byte;
373	dpavlin	36	return;
374	dpavlin	32	}
375
376	dpavlin	42	=head1 Command Line
377	dpavlin	32
378	dpavlin	42	Command-line debugging intrerface is implemented for communication with
379			emulated device
380
381	dpavlin	50	=head2 prompt
382
383	dpavlin	61	my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );
384	dpavlin	50
385			=cut
386
387			my $last = 'r 1';
388
389			sub prompt {
390			my $self = shift;
391			$self->app->sync;
392			my $a = shift;
393			print STDERR $self->hexdump( $a ),
394			$last ? "[$last] " : '',
395			"> ";
396			my $in = <STDIN>;
397			chomp($in);
398			warn "## prompt got: $in\n" if $self->debug;
399			$in \|\|= $last;
400			$last = $in;
401	dpavlin	61	return ( $in, split(/\s+/, $in) ) if $in;
402	dpavlin	50	}
403
404	dpavlin	42	=head2 cli
405
406			$orao->cli();
407
408			=cut
409
410	dpavlin	68	my $show_R = 0;
411
412	dpavlin	42	sub cli {
413			my $self = shift;
414			my $a = $PC \|\| confess "no pc?";
415	dpavlin	68	warn $self->dump_R() if $show_R;
416	dpavlin	61	while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
417	dpavlin	42	my $c = shift @v;
418	dpavlin	61	next unless defined($c);
419	dpavlin	42	my $v = shift @v;
420			$v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
421			@v = map { hex($_) } @v;
422	dpavlin	49	printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v \|\| 'undef'), join(",",@v) if $self->debug;
423	dpavlin	42	if ( $c =~ m/^[qx]/i ) {
424			exit;
425			} elsif ( $c eq '?' ) {
426	dpavlin	50	my $t = $self->trace ? 'on' : 'off' ;
427			my $d = $self->debug ? 'on' : 'off' ;
428	dpavlin	42	warn <<__USAGE__;
429	dpavlin	50	Usage:
430
431	dpavlin	42	x\|q\t\texit
432			e 6000 6010\tdump memory, +/- to walk forward/backward
433			m 1000 ff 00\tput ff 00 on 1000
434			j\|u 1000\t\tjump (change pc)
435			r 42\t\trun 42 instruction opcodes
436	dpavlin	50	t\t\ttrace [$t]
437			d\t\tdebug [$d]
438
439	dpavlin	42	__USAGE__
440	dpavlin	68	warn $self->dump_R;
441	dpavlin	42	} elsif ( $c =~ m/^e/i ) {
442	dpavlin	49	$a = $v if defined($v);
443	dpavlin	42	my $to = shift @v;
444			$to = $a + 32 if ( ! $to \|\| $to <= $a );
445	dpavlin	71	$to = 0xffff if ( $to > 0xffff );
446	dpavlin	59	my $lines = int( ($to - $a + 8) / 8 );
447			printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
448			while ( --$lines ) {
449	dpavlin	42	print $self->hexdump( $a );
450			$a += 8;
451			}
452			$last = '+';
453	dpavlin	68	$show_R = 0;
454	dpavlin	42	} elsif ( $c =~ m/^\+/ ) {
455			$a += 8;
456	dpavlin	68	$show_R = 0;
457	dpavlin	42	} elsif ( $c =~ m/^\-/ ) {
458			$a -= 8;
459	dpavlin	68	$show_R = 0;
460	dpavlin	42	} elsif ( $c =~ m/^m/i ) {
461	dpavlin	70	$a = $v if defined($v);
462	dpavlin	42	$self->poke_code( $a, @v );
463			printf "poke %d bytes at %04x\n", $#v + 1, $a;
464	dpavlin	50	$last = '+';
465	dpavlin	68	$show_R = 0;
466	dpavlin	42	} elsif ( $c =~ m/^l/i ) {
467			my $to = shift @v \|\| 0x1000;
468			$a = $to;
469			$self->load_oraoemu( $v, $a );
470	dpavlin	50	$last = '';
471	dpavlin	42	} elsif ( $c =~ m/^s/i ) {
472			$self->save_dump( $v \|\| 'mem.dump', @v );
473	dpavlin	50	$last = '';
474	dpavlin	42	} elsif ( $c =~ m/^r/i ) {
475			$run_for = $v \|\| 1;
476			print "run_for $run_for instructions\n";
477	dpavlin	68	$show_R = 1;
478	dpavlin	42	last;
479			} elsif ( $c =~ m/^(u\|j)/ ) {
480			my $to = $v \|\| $a;
481			printf "set pc to %04x\n", $to;
482			$PC = $to; # remember for restart
483			$run_for = 1;
484	dpavlin	62	$last = "r $run_for";
485	dpavlin	68	$show_R = 1;
486	dpavlin	42	last;
487			} elsif ( $c =~ m/^t/ ) {
488			$self->trace( not $self->trace );
489			print "trace ", $self->trace ? 'on' : 'off', "\n";
490	dpavlin	64	$last = '';
491	dpavlin	49	} elsif ( $c =~ m/^d/ ) {
492			$self->debug( not $self->debug );
493			print "debug ", $self->debug ? 'on' : 'off', "\n";
494	dpavlin	64	$last = '';
495	dpavlin	42	} else {
496	dpavlin	61	warn "# ignored $line\n" if ($line);
497			$last = '';
498	dpavlin	42	}
499			}
500
501			}
502
503	dpavlin	29	=head1 AUTHOR
504
505			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
506
507			=head1 BUGS
508
509			=head1 ACKNOWLEDGEMENTS
510
511			See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all
512			info about this machine (and even hardware implementation from 2007).
513
514			=head1 COPYRIGHT & LICENSE
515
516			Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
517
518			This program is free software; you can redistribute it and/or modify it
519			under the same terms as Perl itself.
520
521			=cut
522
523			1; # End of Orao