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];
        confess sprintf("can't find memory at address %04x",$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	89	confess sprintf("can't find memory at address %04x",$addr);
288	dpavlin	41	warn sprintf("# Orao::read(%04x) = %02x\n", $addr, $byte) if $self->trace;
289	dpavlin	78
290			# keyboard
291
292			if ( first { $addr == $_ } @kbd_ports ) {
293			warn sprintf("keyboard port: %04x\n",$addr);
294			} elsif ( $addr == 0x87fc ) {
295			warn "0x87fc - arrows/back\n";
296			=for pascal
297			if VKey=VK_RIGHT then Result:=16;
298			if VKey=VK_DOWN then Result:=128;
299			if VKey=VK_UP then Result:=192;
300			if VKey=VK_LEFT then Result:=224;
301			if Ord(KeyPressed)=VK_BACK then Result:=224;
302			=cut
303			} elsif ( $addr == 0x87fd ) {
304			warn "0x87fd - enter\n";
305			=for pascal
306			if KeyPressed=Chr(13) then begin
307			Mem[$FC]:=13;
308			Result:=0;
309			end;
310			=cut
311			} elsif ( $addr == 0x87fa ) {
312			warn "0x87fa = F1 - F4\n";
313			=for pascal
314			if VKey=VK_F4 then Result:=16;
315			if VKey=VK_F3 then Result:=128;
316			if VKey=VK_F2 then Result:=192;
317			if VKey=VK_F1 then Result:=224;
318			=cut
319			} elsif ( $addr == 0x87fb ) {
320			warn "0x87fb\n";
321			=for pascal
322			if KeyPressed=Chr(32) then Result:=32;
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 KeyPressed='>' then Result:=16;
337			if VKey=191 then Result:=16;
338			=cut
339			}
340
341	dpavlin	33	$self->mmap_pixel( $addr, 0, $byte, 0 );
342	dpavlin	32	return $byte;
343			}
344
345			=head2 write
346
347			Write into emory
348
349			write( $address, $byte );
350
351			=cut
352
353			sub write {
354	dpavlin	33	my $self = shift;
355	dpavlin	32	my ($addr,$byte) = @_;
356	dpavlin	41	warn sprintf("# Orao::write(%04x,%02x)\n", $addr, $byte) if $self->trace;
357	dpavlin	32
358			if ( $addr >= 0x6000 && $addr < 0x8000 ) {
359			$self->vram( $addr - 0x6000 , $byte );
360			}
361
362			if ( $addr == 0x8800 ) {
363			warn sprintf "sound ignored: %x\n", $byte;
364			}
365
366	dpavlin	52	if ( $addr > 0xafff ) {
367	dpavlin	65	warn sprintf "write access 0x%04x > 0xafff aborting\n", $addr;
368			return;
369	dpavlin	52	}
370
371	dpavlin	33	$self->mmap_pixel( $addr, $byte, 0, 0 );
372	dpavlin	32
373			$mem[$addr] = $byte;
374	dpavlin	36	return;
375	dpavlin	32	}
376
377	dpavlin	42	=head1 Command Line
378	dpavlin	32
379	dpavlin	42	Command-line debugging intrerface is implemented for communication with
380			emulated device
381
382	dpavlin	50	=head2 prompt
383
384	dpavlin	61	my ( $entered_line, @p ) = $orao->prompt( $address, $last_command );
385	dpavlin	50
386			=cut
387
388			my $last = 'r 1';
389
390			sub prompt {
391			my $self = shift;
392			$self->app->sync;
393			my $a = shift;
394			print STDERR $self->hexdump( $a ),
395			$last ? "[$last] " : '',
396			"> ";
397			my $in = <STDIN>;
398			chomp($in);
399			warn "## prompt got: $in\n" if $self->debug;
400			$in \|\|= $last;
401			$last = $in;
402	dpavlin	61	return ( $in, split(/\s+/, $in) ) if $in;
403	dpavlin	50	}
404
405	dpavlin	42	=head2 cli
406
407			$orao->cli();
408
409			=cut
410
411	dpavlin	68	my $show_R = 0;
412
413	dpavlin	42	sub cli {
414			my $self = shift;
415			my $a = $PC \|\| confess "no pc?";
416	dpavlin	68	warn $self->dump_R() if $show_R;
417	dpavlin	61	while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
418	dpavlin	42	my $c = shift @v;
419	dpavlin	61	next unless defined($c);
420	dpavlin	42	my $v = shift @v;
421			$v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
422			@v = map { hex($_) } @v;
423	dpavlin	49	printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v \|\| 'undef'), join(",",@v) if $self->debug;
424	dpavlin	42	if ( $c =~ m/^[qx]/i ) {
425			exit;
426			} elsif ( $c eq '?' ) {
427	dpavlin	50	my $t = $self->trace ? 'on' : 'off' ;
428			my $d = $self->debug ? 'on' : 'off' ;
429	dpavlin	42	warn <<__USAGE__;
430	dpavlin	50	Usage:
431
432	dpavlin	42	x\|q\t\texit
433			e 6000 6010\tdump memory, +/- to walk forward/backward
434			m 1000 ff 00\tput ff 00 on 1000
435			j\|u 1000\t\tjump (change pc)
436			r 42\t\trun 42 instruction opcodes
437	dpavlin	50	t\t\ttrace [$t]
438			d\t\tdebug [$d]
439
440	dpavlin	42	__USAGE__
441	dpavlin	68	warn $self->dump_R;
442	dpavlin	42	} elsif ( $c =~ m/^e/i ) {
443	dpavlin	49	$a = $v if defined($v);
444	dpavlin	42	my $to = shift @v;
445			$to = $a + 32 if ( ! $to \|\| $to <= $a );
446	dpavlin	71	$to = 0xffff if ( $to > 0xffff );
447	dpavlin	59	my $lines = int( ($to - $a + 8) / 8 );
448			printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
449			while ( --$lines ) {
450	dpavlin	42	print $self->hexdump( $a );
451			$a += 8;
452			}
453			$last = '+';
454	dpavlin	68	$show_R = 0;
455	dpavlin	42	} elsif ( $c =~ m/^\+/ ) {
456			$a += 8;
457	dpavlin	68	$show_R = 0;
458	dpavlin	42	} elsif ( $c =~ m/^\-/ ) {
459			$a -= 8;
460	dpavlin	68	$show_R = 0;
461	dpavlin	42	} elsif ( $c =~ m/^m/i ) {
462	dpavlin	70	$a = $v if defined($v);
463	dpavlin	42	$self->poke_code( $a, @v );
464			printf "poke %d bytes at %04x\n", $#v + 1, $a;
465	dpavlin	50	$last = '+';
466	dpavlin	68	$show_R = 0;
467	dpavlin	42	} elsif ( $c =~ m/^l/i ) {
468			my $to = shift @v \|\| 0x1000;
469			$a = $to;
470			$self->load_oraoemu( $v, $a );
471	dpavlin	50	$last = '';
472	dpavlin	42	} elsif ( $c =~ m/^s/i ) {
473			$self->save_dump( $v \|\| 'mem.dump', @v );
474	dpavlin	50	$last = '';
475	dpavlin	42	} elsif ( $c =~ m/^r/i ) {
476			$run_for = $v \|\| 1;
477			print "run_for $run_for instructions\n";
478	dpavlin	68	$show_R = 1;
479	dpavlin	42	last;
480			} elsif ( $c =~ m/^(u\|j)/ ) {
481			my $to = $v \|\| $a;
482			printf "set pc to %04x\n", $to;
483			$PC = $to; # remember for restart
484			$run_for = 1;
485	dpavlin	62	$last = "r $run_for";
486	dpavlin	68	$show_R = 1;
487	dpavlin	42	last;
488			} elsif ( $c =~ m/^t/ ) {
489			$self->trace( not $self->trace );
490			print "trace ", $self->trace ? 'on' : 'off', "\n";
491	dpavlin	64	$last = '';
492	dpavlin	49	} elsif ( $c =~ m/^d/ ) {
493			$self->debug( not $self->debug );
494			print "debug ", $self->debug ? 'on' : 'off', "\n";
495	dpavlin	64	$last = '';
496	dpavlin	42	} else {
497	dpavlin	61	warn "# ignored $line\n" if ($line);
498			$last = '';
499	dpavlin	42	}
500			}
501
502			}
503
504	dpavlin	29	=head1 AUTHOR
505
506			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
507
508			=head1 BUGS
509
510			=head1 ACKNOWLEDGEMENTS
511
512			See also L<http://www.foing.hr/~fng_josip/orao.htm> which is source of all
513			info about this machine (and even hardware implementation from 2007).
514
515			=head1 COPYRIGHT & LICENSE
516
517			Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
518
519			This program is free software; you can redistribute it and/or modify it
520			under the same terms as Perl itself.
521
522			=cut
523
524			1; # End of Orao