viewvc.cgi/VRac/Tape.pm

package Tape;

# Dobrica Pavlinusic, <dpavlin@rot13.org> 08/03/07 11:11:56 CEST

use strict;
use warnings;

use base qw/Class::Accessor/;
__PACKAGE__->mk_accessors(qw(tape tape_path tape_pos trace));

use File::Slurp;
use Carp qw/confess/;

=head1 NAME

Tape - implement tape reader/recorder

=cut

=head2 read_tape

  my $byte = $self->read_tape;

=cut

my $last_warn = '';

sub _warn {
        my $msg = shift;
        if ( $msg ne $last_warn ) {
                warn "$msg\n";
                $last_warn = $msg;
        }
}

my $c_0 = 0;
my $c_1 = 0;
my $mask = 1;

my $bits = '';

sub read_tape {
        my $self = shift;
        if ( ! $self->tape ) {
                _warn "please load tape!";
                return 0;
        }
        my $pos = $self->tape_pos;
        my $tape = $self->tape;
        if ( $pos > length( $tape ) ) {
                _warn "end of tape [$pos]";
                return -1;
        }

        if ( $c_0 ) {
                $c_0--;
                $bits .= ".";
                return 0;
        }
        if ( $c_1 ) {
                $c_1--;
                $bits .= "X";
                return 255;
        }

        $mask = $mask << 1;
        if ( $mask > 0x80 ) {
                $pos++;
                $self->tape_pos( $pos );
                $mask = 1;

                warn "# $bits\n";
                $bits = '';
        };

        my $byte = ord( substr($self->tape,$pos,1) );
        my $bit = $byte & $mask;
        warn sprintf("tape pos %d 0x%04x mask %02x and %02x = %d\n", $pos, $pos, $mask, $byte, $bit); # if $self->trace;

        ( $c_0, $c_1 ) = ( 0x17, 0x17 );
        ( $c_0, $c_1 ) = ( 0x30, 0x30 ) if $bit;

        return 0;
}

=head2 write_tape

  $self->write_tape( $byte );

=cut


sub write_tape {
        my ( $self, $byte ) = @_;

        $self->append_to_file( 'tape.dmp', $byte );

        return $byte;
}

=head2 load_tape

  $self->load_tape( '/path/to/file' );

=cut

sub load_tape {
        my $self = shift;
        my $path = shift || return;

        my $tape = read_file( $path ) || confess "can't load $path: $!";
        $self->tape_path( $path );

        $self->tape_pos( 0 );
        $self->tape( $tape );
        warn "loaded tape $path ", -s $path, " bytes\n";
        return 1;
}

=head2 tape_status

  print $self->tape_status;

=cut

sub tape_status {
        my $self = shift;

        return "No tape in (simulated) drive" unless $self->tape;

        my $size = length( $self->tape );

        return sprintf(
                "tape file: %s with %d 0x%x bytes, current position: %d 0x%x",
                $self->tape_path, $size, $size, $self->pos, $self->pos,
        );
}

=head1 SEE ALSO

L<VRac>

=cut

1;
1	dpavlin	109	package Tape;
2
3			# Dobrica Pavlinusic, <dpavlin@rot13.org> 08/03/07 11:11:56 CEST
4
5			use strict;
6			use warnings;
7
8			use base qw/Class::Accessor/;
9	dpavlin	169	__PACKAGE__->mk_accessors(qw(tape tape_path tape_pos trace));
10	dpavlin	109
11			use File::Slurp;
12			use Carp qw/confess/;
13
14			=head1 NAME
15
16			Tape - implement tape reader/recorder
17
18			=cut
19
20			=head2 read_tape
21
22	dpavlin	145	my $byte = $self->read_tape;
23	dpavlin	109
24			=cut
25
26			my $last_warn = '';
27
28			sub _warn {
29			my $msg = shift;
30			if ( $msg ne $last_warn ) {
31			warn "$msg\n";
32			$last_warn = $msg;
33			}
34			}
35
36	dpavlin	191	my $c_0 = 0;
37			my $c_1 = 0;
38			my $mask = 1;
39
40			my $bits = '';
41
42	dpavlin	109	sub read_tape {
43			my $self = shift;
44			if ( ! $self->tape ) {
45			_warn "please load tape!";
46			return 0;
47			}
48			my $pos = $self->tape_pos;
49			my $tape = $self->tape;
50			if ( $pos > length( $tape ) ) {
51			_warn "end of tape [$pos]";
52			return -1;
53			}
54	dpavlin	110
55	dpavlin	191	if ( $c_0 ) {
56			$c_0--;
57			$bits .= ".";
58			return 0;
59			}
60			if ( $c_1 ) {
61			$c_1--;
62			$bits .= "X";
63			return 255;
64			}
65
66			$mask = $mask << 1;
67			if ( $mask > 0x80 ) {
68			$pos++;
69			$self->tape_pos( $pos );
70			$mask = 1;
71
72			warn "# $bits\n";
73			$bits = '';
74			};
75
76	dpavlin	145	my $byte = ord( substr($self->tape,$pos,1) );
77	dpavlin	191	my $bit = $byte & $mask;
78			warn sprintf("tape pos %d 0x%04x mask %02x and %02x = %d\n", $pos, $pos, $mask, $byte, $bit); # if $self->trace;
79	dpavlin	114
80	dpavlin	191	( $c_0, $c_1 ) = ( 0x17, 0x17 );
81			( $c_0, $c_1 ) = ( 0x30, 0x30 ) if $bit;
82	dpavlin	114
83	dpavlin	191	return 0;
84	dpavlin	109	}
85
86	dpavlin	145	=head2 write_tape
87
88			$self->write_tape( $byte );
89
90			=cut
91
92
93			sub write_tape {
94			my ( $self, $byte ) = @_;
95
96	dpavlin	191	$self->append_to_file( 'tape.dmp', $byte );
97	dpavlin	145
98			return $byte;
99			}
100
101	dpavlin	109	=head2 load_tape
102
103			$self->load_tape( '/path/to/file' );
104
105			=cut
106
107			sub load_tape {
108			my $self = shift;
109			my $path = shift \|\| return;
110
111			my $tape = read_file( $path ) \|\| confess "can't load $path: $!";
112	dpavlin	169	$self->tape_path( $path );
113	dpavlin	109
114			$self->tape_pos( 0 );
115			$self->tape( $tape );
116	dpavlin	172	warn "loaded tape $path ", -s $path, " bytes\n";
117	dpavlin	109	return 1;
118			}
119
120	dpavlin	177	=head2 tape_status
121	dpavlin	169
122			print $self->tape_status;
123
124			=cut
125
126			sub tape_status {
127			my $self = shift;
128
129			return "No tape in (simulated) drive" unless $self->tape;
130
131			my $size = length( $self->tape );
132
133			return sprintf(
134			"tape file: %s with %d 0x%x bytes, current position: %d 0x%x",
135			$self->tape_path, $size, $size, $self->pos, $self->pos,
136			);
137			}
138
139	dpavlin	145	=head1 SEE ALSO
140	dpavlin	109
141	dpavlin	145	L<VRac>
142
143			=cut
144
145	dpavlin	109	1;