/[VRac]/Tape.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Annotation of /Tape.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 215 - (hide annotations)
Thu Sep 3 10:23:27 2009 UTC (14 years, 6 months ago) by dpavlin
File size: 2245 byte(s)
don't die if tape is unavailable
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 dpavlin 109 sub read_tape {
41     my $self = shift;
42 dpavlin 193
43     my $pos = $self->tape_pos;
44     my $tape = $self->tape;
45    
46     if ( ! $tape ) {
47 dpavlin 109 _warn "please load tape!";
48     return 0;
49     }
50 dpavlin 110
51 dpavlin 191 if ( $c_0 ) {
52     $c_0--;
53     return 0;
54     }
55     if ( $c_1 ) {
56     $c_1--;
57     return 255;
58     }
59    
60     $mask = $mask << 1;
61     if ( $mask > 0x80 ) {
62     $pos++;
63     $self->tape_pos( $pos );
64     $mask = 1;
65 dpavlin 193 }
66 dpavlin 191
67 dpavlin 193 my $byte = 0;
68     my $tape_len = length( $tape );
69    
70     if ( $pos <= $tape_len ) {
71     $byte = ord( substr($self->tape,$pos,1) );
72     } elsif ( $pos == $tape_len ) {
73     _warn "end of tape [$pos]";
74     }
75    
76 dpavlin 191 my $bit = $byte & $mask;
77 dpavlin 114
78 dpavlin 194 warn sprintf("## tape pos %d/%d %.02f%% 0x%04x = %02x\n", $pos, $tape_len, ($pos * 100) / $tape_len, $pos, $byte) if $mask == 1;
79    
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 dpavlin 210 $self->load_tape( '/path/to/file', $position );
104 dpavlin 109
105     =cut
106    
107     sub load_tape {
108     my $self = shift;
109     my $path = shift || return;
110 dpavlin 210 my $pos = shift || 0;
111 dpavlin 109
112 dpavlin 215 return unless -e $path;
113    
114 dpavlin 109 my $tape = read_file( $path ) || confess "can't load $path: $!";
115 dpavlin 169 $self->tape_path( $path );
116 dpavlin 109
117 dpavlin 210 $self->tape_pos( $pos );
118 dpavlin 109 $self->tape( $tape );
119 dpavlin 210 warn "loaded tape $path ", -s $path, " bytes at $pos\n";
120 dpavlin 109 return 1;
121     }
122    
123 dpavlin 177 =head2 tape_status
124 dpavlin 169
125     print $self->tape_status;
126    
127     =cut
128    
129     sub tape_status {
130     my $self = shift;
131    
132     return "No tape in (simulated) drive" unless $self->tape;
133    
134     my $size = length( $self->tape );
135    
136     return sprintf(
137     "tape file: %s with %d 0x%x bytes, current position: %d 0x%x",
138 dpavlin 194 $self->tape_path, $size, $size, $self->tape_pos, $self->tape_pos,
139 dpavlin 169 );
140     }
141    
142 dpavlin 145 =head1 SEE ALSO
143 dpavlin 109
144 dpavlin 145 L<VRac>
145    
146     =cut
147    
148 dpavlin 109 1;

  ViewVC Help
Powered by ViewVC 1.1.26