line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Image::Xbm ; # Documented at the __END__ |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
# $Id: Xbm.pm,v 1.19 2000/11/09 19:05:31 mark Exp mark $ |
4
|
|
|
|
|
|
|
|
5
|
1
|
|
|
1
|
|
267699
|
use strict ; |
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
126
|
|
6
|
|
|
|
|
|
|
|
7
|
1
|
|
|
1
|
|
7
|
use vars qw( $VERSION @ISA ) ; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
100
|
|
8
|
|
|
|
|
|
|
$VERSION = '1.08' ; |
9
|
|
|
|
|
|
|
|
10
|
1
|
|
|
1
|
|
2822
|
use Image::Base ; |
|
1
|
|
|
|
|
6568
|
|
|
1
|
|
|
|
|
107
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
@ISA = qw( Image::Base ) ; |
13
|
|
|
|
|
|
|
|
14
|
1
|
|
|
1
|
|
14
|
use Carp qw( carp croak ) ; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
130
|
|
15
|
1
|
|
|
1
|
|
5155
|
use Symbol () ; |
|
1
|
|
|
|
|
3072
|
|
|
1
|
|
|
|
|
3182
|
|
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
# Private class data |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
my $DEF_SIZE = 8192 ; |
21
|
|
|
|
|
|
|
my $UNSET = -1 ; |
22
|
|
|
|
|
|
|
my $MASK = 7 ; |
23
|
|
|
|
|
|
|
my $ROWS = 12 ; |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
# If you inherit don't clobber these fields! |
26
|
|
|
|
|
|
|
my @FIELD = qw( -file -width -height -hotx -hoty -bits |
27
|
|
|
|
|
|
|
-setch -unsetch -sethotch -unsethotch ) ; |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
my @MASK = ( 0x01, 0x02, 0x04, 0x08, 0x10, 0x20, 0x40, 0x80 ) ; |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
### Private methods |
33
|
|
|
|
|
|
|
# |
34
|
|
|
|
|
|
|
# _class_get class object |
35
|
|
|
|
|
|
|
# _class_set class object |
36
|
|
|
|
|
|
|
# _get object inherited |
37
|
|
|
|
|
|
|
# _set object inherited |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
{ |
40
|
|
|
|
|
|
|
my %Ch = ( -setch => '#', -unsetch => '-', |
41
|
|
|
|
|
|
|
-sethotch => 'H', -unsethotch => 'h' ) ; |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
sub _class_get { # Class and object method |
45
|
7
|
|
|
7
|
|
12
|
my $self = shift ; |
46
|
7
|
|
33
|
|
|
26
|
my $class = ref( $self ) || $self ; |
47
|
|
|
|
|
|
|
|
48
|
7
|
|
|
|
|
35
|
$Ch{shift()} ; |
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
sub _class_set { # Class and object method |
53
|
0
|
|
|
0
|
|
0
|
my $self = shift ; |
54
|
0
|
|
0
|
|
|
0
|
my $class = ref( $self ) || $self ; |
55
|
|
|
|
|
|
|
|
56
|
0
|
|
|
|
|
0
|
my $field = shift ; |
57
|
0
|
|
|
|
|
0
|
my $val = shift ; |
58
|
|
|
|
|
|
|
|
59
|
0
|
0
|
|
|
|
0
|
croak "_class_set() `$field' has no value" unless defined $val ; |
60
|
|
|
|
|
|
|
|
61
|
0
|
|
|
|
|
0
|
$Ch{$field} = $val ; |
62
|
|
|
|
|
|
|
} |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
|
66
|
0
|
|
|
0
|
|
0
|
sub DESTROY { |
67
|
|
|
|
|
|
|
; # Save's time |
68
|
|
|
|
|
|
|
} |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
### Public methods |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
sub new_from_string { # Class and object method |
74
|
1
|
|
|
1
|
1
|
68
|
my $self = shift ; |
75
|
1
|
|
33
|
|
|
9
|
my $class = ref( $self ) || $self ; |
76
|
|
|
|
|
|
|
|
77
|
1
|
|
|
|
|
2
|
my @line ; |
78
|
|
|
|
|
|
|
|
79
|
1
|
50
|
|
|
|
4
|
if( @_ > 1 ) { |
80
|
0
|
|
|
|
|
0
|
chomp( @line = @_ ) ; |
81
|
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
else { |
83
|
1
|
|
|
|
|
9
|
@line = split /\n/, $_[0] ; |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
|
86
|
1
|
|
|
|
|
7
|
my( $setch, $sethotch, $unsethotch ) = |
87
|
|
|
|
|
|
|
$class->get( '-setch', '-sethotch', '-unsethotch' ) ; |
88
|
|
|
|
|
|
|
|
89
|
1
|
|
|
|
|
2
|
my $width ; |
90
|
1
|
|
|
|
|
3
|
my $y = 0 ; |
91
|
|
|
|
|
|
|
|
92
|
1
|
|
|
|
|
6
|
$self = $class->new( '-width' => $DEF_SIZE, '-height' => $DEF_SIZE ) ; |
93
|
|
|
|
|
|
|
|
94
|
1
|
|
|
|
|
11
|
foreach my $line ( @line ) { |
95
|
6
|
50
|
|
|
|
25
|
next if $line =~ /^\s*$/ ; |
96
|
6
|
100
|
|
|
|
11
|
unless( defined $width ) { |
97
|
1
|
|
|
|
|
2
|
$width = length $line ; |
98
|
1
|
|
|
|
|
4
|
$self->_set( '-width' => $width ) ; |
99
|
|
|
|
|
|
|
} |
100
|
6
|
|
|
|
|
19
|
for( my $x = 0 ; $x < $width ; $x++ ) { |
101
|
30
|
|
|
|
|
39
|
my $c = substr( $line, $x, 1 ) ; |
102
|
30
|
50
|
|
|
|
85
|
$self->xybit( $x, $y, $c eq $setch ? 1 : $c eq $sethotch ? 1 : 0 ) ; |
|
|
100
|
|
|
|
|
|
103
|
30
|
50
|
33
|
|
|
172
|
$self->set( '-hotx' => $x, '-hoty' => $y ) |
104
|
|
|
|
|
|
|
if $c eq $sethotch or $c eq $unsethotch ; |
105
|
|
|
|
|
|
|
} |
106
|
6
|
|
|
|
|
9
|
$y++ ; |
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
|
109
|
1
|
|
|
|
|
13
|
$self->_set( '-height' => $y ) ; |
110
|
|
|
|
|
|
|
|
111
|
1
|
|
|
|
|
6
|
$self ; |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
sub new { # Class and object method |
116
|
4
|
|
|
4
|
1
|
389
|
my $self = shift ; |
117
|
4
|
|
66
|
|
|
18
|
my $class = ref( $self ) || $self ; |
118
|
4
|
100
|
|
|
|
10
|
my $obj = ref $self ? $self : undef ; |
119
|
4
|
|
|
|
|
14
|
my %arg = @_ ; |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
# Defaults |
122
|
4
|
|
|
|
|
18
|
$self = { |
123
|
|
|
|
|
|
|
'-hotx' => $UNSET, |
124
|
|
|
|
|
|
|
'-hoty' => $UNSET, |
125
|
|
|
|
|
|
|
'-bits' => '', |
126
|
|
|
|
|
|
|
} ; |
127
|
|
|
|
|
|
|
|
128
|
4
|
|
|
|
|
9
|
bless $self, $class ; |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
# If $obj->new copy original object's data |
131
|
4
|
100
|
|
|
|
41
|
if( defined $obj ) { |
132
|
1
|
|
|
|
|
2
|
foreach my $field ( @FIELD ) { |
133
|
10
|
|
|
|
|
57
|
$self->_set( $field, $obj->get( $field ) ) ; |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
# Any options specified override |
138
|
4
|
|
|
|
|
16
|
foreach my $field ( @FIELD ) { |
139
|
40
|
100
|
|
|
|
148
|
$self->_set( $field, $arg{$field} ) if defined $arg{$field} ; |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
|
142
|
4
|
|
|
|
|
15
|
my $file = $self->get( '-file' ) ; |
143
|
4
|
50
|
66
|
|
|
63
|
$self->load if defined $file and -r $file and not $self->{'-bits'} ; |
|
|
|
66
|
|
|
|
|
144
|
|
|
|
|
|
|
|
145
|
4
|
50
|
66
|
|
|
26
|
croak "new() `$file' not found or unreadable" |
146
|
|
|
|
|
|
|
if defined $file and not defined $self->get( '-width' ) ; |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
|
149
|
4
|
|
|
|
|
9
|
foreach my $field ( qw( -width -height ) ) { |
150
|
8
|
50
|
|
|
|
18
|
croak "new() $field must be set" unless defined $self->get( $field ) ; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
|
153
|
4
|
|
|
|
|
15
|
$self ; |
154
|
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
sub new_from_serialised { # Class and object method |
158
|
1
|
|
|
1
|
1
|
197
|
my $self = shift ; |
159
|
1
|
|
33
|
|
|
9
|
my $class = ref( $self ) || $self ; |
160
|
1
|
|
|
|
|
2
|
my $serialised = shift ; |
161
|
|
|
|
|
|
|
|
162
|
1
|
|
|
|
|
7
|
$self = $class->new( '-width' => $DEF_SIZE, '-height' => $DEF_SIZE ) ; |
163
|
|
|
|
|
|
|
|
164
|
1
|
|
|
|
|
10
|
my( $flen, $blen, $width, $height, $hotx, $hoty, $data ) = |
165
|
|
|
|
|
|
|
unpack "n N n n n n A*", $serialised ; |
166
|
|
|
|
|
|
|
|
167
|
1
|
|
|
|
|
7
|
my( $file, $bits ) = unpack "A$flen A$blen", $data ; |
168
|
|
|
|
|
|
|
|
169
|
1
|
|
|
|
|
4
|
$self->_set( '-file' => $file ) ; |
170
|
1
|
|
|
|
|
8
|
$self->_set( '-width' => $width ) ; |
171
|
1
|
|
|
|
|
9
|
$self->_set( '-height' => $height ) ; |
172
|
1
|
50
|
|
|
|
9
|
$self->_set( '-hotx' => $hotx > $width ? $UNSET : $hotx ) ; |
173
|
1
|
50
|
|
|
|
9
|
$self->_set( '-hoty' => $hoty > $height ? $UNSET : $hoty ) ; |
174
|
1
|
|
|
|
|
7
|
$self->_set( '-bits' => $bits ) ; |
175
|
|
|
|
|
|
|
|
176
|
1
|
|
|
|
|
7
|
$self ; |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
sub serialise { # Object method |
181
|
1
|
|
|
1
|
1
|
846
|
my $self = shift ; |
182
|
|
|
|
|
|
|
# my $class = ref( $self ) || $self ; |
183
|
|
|
|
|
|
|
|
184
|
1
|
|
|
|
|
6
|
my( $file, $bits ) = $self->get( -file, -bits ) ; |
185
|
1
|
|
|
|
|
3
|
my $flen = length( $file ) ; |
186
|
1
|
|
|
|
|
3
|
my $blen = length( $bits ) ; |
187
|
|
|
|
|
|
|
|
188
|
1
|
|
|
|
|
7
|
pack "n N n n n n A$flen A$blen", |
189
|
|
|
|
|
|
|
$flen, $blen, |
190
|
|
|
|
|
|
|
$self->get( -width ), $self->get( -height ), |
191
|
|
|
|
|
|
|
$self->get( -hotx ), $self->get( -hoty ), |
192
|
|
|
|
|
|
|
$file, $bits ; |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
sub get { # Object method (and class method for class attributes) |
197
|
105
|
|
|
105
|
1
|
799
|
my $self = shift ; |
198
|
105
|
|
66
|
|
|
363
|
my $class = ref( $self ) || $self ; |
199
|
|
|
|
|
|
|
|
200
|
105
|
|
|
|
|
102
|
my @result ; |
201
|
|
|
|
|
|
|
|
202
|
105
|
|
|
|
|
193
|
while( @_ ) { |
203
|
111
|
|
|
|
|
242
|
my $field = shift ; |
204
|
|
|
|
|
|
|
|
205
|
111
|
100
|
|
|
|
225
|
if( $field =~ /^-(?:un)?set(?:hot)?ch$/o ) { |
206
|
7
|
|
|
|
|
24
|
push @result, $class->_class_get( $field ) ; |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
else { |
209
|
104
|
|
|
|
|
263
|
push @result, $self->_get( $field ) ; |
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
|
213
|
105
|
100
|
|
|
|
928
|
wantarray ? @result : shift @result ; |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
sub set { # Object method (and class method for class attributes) |
218
|
4
|
|
|
4
|
1
|
7
|
my $self = shift ; |
219
|
4
|
|
33
|
|
|
13
|
my $class = ref( $self ) || $self ; |
220
|
|
|
|
|
|
|
|
221
|
4
|
|
|
|
|
24
|
while( @_ ) { |
222
|
4
|
|
|
|
|
6
|
my $field = shift ; |
223
|
4
|
|
|
|
|
6
|
my $val = shift ; |
224
|
|
|
|
|
|
|
|
225
|
4
|
50
|
|
|
|
11
|
carp "set() -field has no value" unless defined $val ; |
226
|
4
|
50
|
33
|
|
|
38
|
carp "set() $field is read-only" |
|
|
|
33
|
|
|
|
|
227
|
|
|
|
|
|
|
if $field eq '-bits' or $field eq '-width' or $field eq '-height' ; |
228
|
4
|
50
|
33
|
|
|
18
|
carp "set() -hotx `$val' is out of range" |
|
|
|
66
|
|
|
|
|
229
|
|
|
|
|
|
|
if $field eq '-hotx' and ( $val < $UNSET or $val >= $self->get( '-width' ) ) ; |
230
|
4
|
50
|
33
|
|
|
18
|
carp "set() -hoty `$val' is out of range" |
|
|
|
66
|
|
|
|
|
231
|
|
|
|
|
|
|
if $field eq '-hoty' and ( $val < $UNSET or $val >= $self->get( '-height' ) ) ; |
232
|
|
|
|
|
|
|
|
233
|
4
|
50
|
|
|
|
10
|
if( $field =~ /^-(?:un)?set(?:hot)?ch$/o ) { |
234
|
0
|
|
|
|
|
0
|
$class->_class_set( $field, $val ) ; |
235
|
|
|
|
|
|
|
} |
236
|
|
|
|
|
|
|
else { |
237
|
4
|
|
|
|
|
14
|
$self->_set( $field, $val ) ; |
238
|
|
|
|
|
|
|
} |
239
|
|
|
|
|
|
|
} |
240
|
|
|
|
|
|
|
} |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
sub xybit { # Object method |
244
|
60
|
|
|
60
|
1
|
85
|
my $self = shift ; |
245
|
|
|
|
|
|
|
# my $class = ref( $self ) || $self ; |
246
|
|
|
|
|
|
|
|
247
|
60
|
|
|
|
|
75
|
my( $x, $y, $val ) = @_ ; |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
# No range checking |
250
|
60
|
|
|
|
|
96
|
my $offset = ( $y * $self->get( '-width' ) ) + $x ; |
251
|
|
|
|
|
|
|
|
252
|
60
|
100
|
|
|
|
97
|
if( defined $val ) { |
253
|
30
|
|
|
|
|
78
|
CORE::vec( $self->{'-bits'}, $offset, 1 ) = $val ; |
254
|
|
|
|
|
|
|
} |
255
|
|
|
|
|
|
|
else { |
256
|
30
|
|
|
|
|
129
|
CORE::vec( $self->{'-bits'}, $offset, 1 ) ; |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
sub xy { # Object method |
262
|
0
|
|
|
0
|
1
|
0
|
my $self = shift ; |
263
|
|
|
|
|
|
|
# my $class = ref( $self ) || $self ; |
264
|
|
|
|
|
|
|
|
265
|
0
|
|
|
|
|
0
|
my( $x, $y, $val ) = @_ ; |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
# No range checking |
268
|
0
|
|
|
|
|
0
|
my $offset = ( $y * $self->get( '-width' ) ) + $x ; |
269
|
|
|
|
|
|
|
|
270
|
0
|
0
|
|
|
|
0
|
if( defined $val ) { |
271
|
0
|
0
|
0
|
|
|
0
|
$val = 1 if ( $val =~ /^\d+$/ and $val >= 1 ) or |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
272
|
|
|
|
|
|
|
( lc $val eq 'black' ) or |
273
|
|
|
|
|
|
|
( $val =~ /^#(\d+)$/ and hex $1 ) ; |
274
|
0
|
|
|
|
|
0
|
CORE::vec( $self->{'-bits'}, $offset, 1 ) = $val ; |
275
|
|
|
|
|
|
|
} |
276
|
|
|
|
|
|
|
else { |
277
|
0
|
0
|
|
|
|
0
|
CORE::vec( $self->{'-bits'}, $offset, 1 ) ? 'black' : 'white' ; |
278
|
|
|
|
|
|
|
} |
279
|
|
|
|
|
|
|
} |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
sub vec { # Object method |
283
|
0
|
|
|
0
|
1
|
0
|
my $self = shift ; |
284
|
|
|
|
|
|
|
# my $class = ref( $self ) || $self ; |
285
|
|
|
|
|
|
|
|
286
|
0
|
|
|
|
|
0
|
my( $offset, $val ) = @_ ; |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
# No range checking |
289
|
0
|
0
|
|
|
|
0
|
if( defined $val ) { |
290
|
0
|
|
|
|
|
0
|
CORE::vec( $self->{'-bits'}, $offset, 1 ) = $val ; |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
else { |
293
|
0
|
|
|
|
|
0
|
CORE::vec( $self->{'-bits'}, $offset, 1 ) ; |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
} |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
sub is_equal { # Object method |
299
|
1
|
|
|
1
|
1
|
6
|
my $self = shift ; |
300
|
1
|
|
33
|
|
|
8
|
my $class = ref( $self ) || $self ; |
301
|
1
|
|
|
|
|
2
|
my $obj = shift ; |
302
|
|
|
|
|
|
|
|
303
|
1
|
50
|
33
|
|
|
68
|
croak "is_equal() can only compare $class objects" |
304
|
|
|
|
|
|
|
unless ref $obj and $obj->isa( __PACKAGE__ ) ; |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
# We ignore -file, -hotx and -hoty when we consider equality. |
307
|
1
|
50
|
33
|
|
|
4
|
return 0 if $self->get( '-width' ) != $obj->get( '-width' ) or |
|
|
|
33
|
|
|
|
|
308
|
|
|
|
|
|
|
$self->get( '-height' ) != $obj->get( '-height' ) or |
309
|
|
|
|
|
|
|
$self->get( '-bits' ) ne $obj->get( '-bits' ) ; |
310
|
|
|
|
|
|
|
|
311
|
1
|
|
|
|
|
4
|
1 ; |
312
|
|
|
|
|
|
|
} |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
sub as_string { # Object method |
316
|
0
|
|
|
0
|
1
|
0
|
my $self = shift ; |
317
|
|
|
|
|
|
|
# my $class = ref( $self ) || $self ; |
318
|
|
|
|
|
|
|
|
319
|
0
|
|
0
|
|
|
0
|
my $hotch = shift || 0 ; |
320
|
|
|
|
|
|
|
|
321
|
0
|
|
|
|
|
0
|
my( $setch, $unsetch, |
322
|
|
|
|
|
|
|
$sethotch, $unsethotch, |
323
|
|
|
|
|
|
|
$hotx, $hoty, |
324
|
|
|
|
|
|
|
$bits, |
325
|
|
|
|
|
|
|
$width, $height ) = |
326
|
|
|
|
|
|
|
$self->get( |
327
|
|
|
|
|
|
|
'-setch', '-unsetch', |
328
|
|
|
|
|
|
|
'-sethotch', '-unsethotch', |
329
|
|
|
|
|
|
|
'-hotx', '-hoty', |
330
|
|
|
|
|
|
|
'-bits', |
331
|
|
|
|
|
|
|
'-width', '-height' ) ; |
332
|
|
|
|
|
|
|
|
333
|
0
|
|
|
|
|
0
|
my $bitindex = 0 ; |
334
|
0
|
|
|
|
|
0
|
my $string = '' ; |
335
|
|
|
|
|
|
|
|
336
|
0
|
|
|
|
|
0
|
for( my $y = 0 ; $y < $height ; $y++ ) { |
337
|
0
|
|
|
|
|
0
|
for( my $x = 0 ; $x < $width ; $x++ ) { |
338
|
0
|
0
|
0
|
|
|
0
|
if( $hotch and $x == $hotx and $y == $hoty ) { |
|
|
|
0
|
|
|
|
|
339
|
0
|
0
|
|
|
|
0
|
$string .= CORE::vec( $bits, $bitindex, 1 ) ? |
340
|
|
|
|
|
|
|
$sethotch : $unsethotch ; |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
else { |
343
|
0
|
0
|
|
|
|
0
|
$string .= CORE::vec( $bits, $bitindex, 1 ) ? |
344
|
|
|
|
|
|
|
$setch : $unsetch ; |
345
|
|
|
|
|
|
|
} |
346
|
0
|
|
|
|
|
0
|
$bitindex++ ; |
347
|
|
|
|
|
|
|
} |
348
|
0
|
|
|
|
|
0
|
$string .= "\n" ; |
349
|
|
|
|
|
|
|
} |
350
|
|
|
|
|
|
|
|
351
|
0
|
|
|
|
|
0
|
$string ; |
352
|
|
|
|
|
|
|
} |
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
sub as_binstring { # Object method |
356
|
3
|
|
|
3
|
1
|
16
|
my $self = shift ; |
357
|
|
|
|
|
|
|
# my $class = ref( $self ) || $self ; |
358
|
|
|
|
|
|
|
|
359
|
3
|
|
|
|
|
15
|
unpack "b*", $self->get( '-bits' ) ; |
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
# The algorithm is based on the one used in Thomas Boutell's GD library. |
364
|
|
|
|
|
|
|
sub load { # Object method |
365
|
1
|
|
|
1
|
1
|
3
|
my $self = shift ; |
366
|
|
|
|
|
|
|
# my $class = ref( $self ) || $self ; |
367
|
|
|
|
|
|
|
|
368
|
1
|
|
33
|
|
|
7
|
my $file = shift() || $self->get( '-file' ) ; |
369
|
|
|
|
|
|
|
|
370
|
1
|
50
|
|
|
|
6
|
croak "load() no file specified" unless $file ; |
371
|
|
|
|
|
|
|
|
372
|
1
|
|
|
|
|
4
|
$self->set( '-file', $file ) ; |
373
|
|
|
|
|
|
|
|
374
|
1
|
|
|
|
|
8
|
my( @val, $width, $height, $hotx, $hoty ) ; |
375
|
1
|
|
|
|
|
2
|
local $_ ; |
376
|
1
|
|
|
|
|
5
|
my $fh = Symbol::gensym ; |
377
|
|
|
|
|
|
|
|
378
|
1
|
50
|
|
|
|
18
|
if( not ref $file ) { |
|
|
0
|
|
|
|
|
|
379
|
1
|
50
|
|
|
|
66
|
open $fh, $file or croak "load() failed to open `$file': $!" ; |
380
|
|
|
|
|
|
|
} |
381
|
|
|
|
|
|
|
elsif( ref($file) eq 'SCALAR' ) { |
382
|
0
|
|
|
|
|
0
|
require IO::String; |
383
|
0
|
|
|
|
|
0
|
$fh = IO::String->new( $$file ); |
384
|
|
|
|
|
|
|
} |
385
|
|
|
|
|
|
|
else { |
386
|
0
|
0
|
|
|
|
0
|
seek($file, 0, 0) or croak "load() can't rewind handle for `$file': $!"; |
387
|
0
|
|
|
|
|
0
|
$fh = $file; |
388
|
|
|
|
|
|
|
} |
389
|
|
|
|
|
|
|
|
390
|
1
|
|
|
|
|
24
|
while( <$fh> ) { |
391
|
4
|
100
|
|
|
|
23
|
$width = $1, next if /#define.*width\s+(\d+)/o ; |
392
|
3
|
100
|
|
|
|
21
|
$height = $1, next if /#define.*height\s+(\d+)/o ; |
393
|
2
|
50
|
|
|
|
8
|
$hotx = $1, next if /#define.*_x_hot\s+(\d+)/o ; |
394
|
2
|
50
|
|
|
|
6
|
$hoty = $1, next if /#define.*_y_hot\s+(\d+)/o ; |
395
|
2
|
|
|
|
|
17
|
push @val, map { hex } /0[xX]([A-Fa-f\d][A-Fa-f\d]?)/g ; |
|
6
|
|
|
|
|
23
|
|
396
|
|
|
|
|
|
|
} |
397
|
1
|
50
|
33
|
|
|
16
|
croak "load() failed to find dimension(s) in `$file'" |
398
|
|
|
|
|
|
|
unless defined $width and defined $height ; |
399
|
|
|
|
|
|
|
|
400
|
1
|
50
|
|
|
|
62
|
close $fh or croak "load() failed to close `$file': $!" ; |
401
|
|
|
|
|
|
|
|
402
|
1
|
|
|
|
|
7
|
$self->_set( '-width', $width ) ; |
403
|
1
|
|
|
|
|
9
|
$self->_set( '-height', $height ) ; |
404
|
1
|
50
|
|
|
|
10
|
$self->set( '-hotx', defined $hotx ? $hotx : $UNSET ) ; |
405
|
1
|
50
|
|
|
|
12
|
$self->set( '-hoty', defined $hoty ? $hoty : $UNSET ) ; |
406
|
|
|
|
|
|
|
|
407
|
1
|
|
|
|
|
8
|
my( $x, $y ) = ( 0, 0 ) ; |
408
|
1
|
|
|
|
|
3
|
my $bitindex = 0 ; |
409
|
1
|
|
|
|
|
722
|
my $bits = '' ; |
410
|
|
|
|
|
|
|
BYTE: |
411
|
1
|
|
|
|
|
4
|
for( my $i = 0 ; ; $i++ ) { |
412
|
|
|
|
|
|
|
BIT: |
413
|
6
|
|
|
|
|
23
|
for( my $bit = 1 ; $bit <= 128 ; $bit <<= 1 ) { |
414
|
30
|
100
|
|
|
|
73
|
CORE::vec( $bits, $bitindex++, 1 ) = ( $val[$i] & $bit ) ? 1 : 0 ; |
415
|
30
|
|
|
|
|
77
|
$x++ ; |
416
|
30
|
100
|
|
|
|
75
|
if( $x == $width ) { |
417
|
6
|
|
|
|
|
6
|
$x = 0 ; |
418
|
6
|
|
|
|
|
7
|
$y++ ; |
419
|
6
|
100
|
|
|
|
10
|
last BYTE if $y == $height ; |
420
|
5
|
|
|
|
|
12
|
last BIT ; |
421
|
|
|
|
|
|
|
} |
422
|
|
|
|
|
|
|
} |
423
|
|
|
|
|
|
|
} |
424
|
|
|
|
|
|
|
|
425
|
1
|
|
|
|
|
101
|
$self->_set( '-bits', $bits ) ; |
426
|
|
|
|
|
|
|
} |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
# The algorithm is based on the X Consortium's bmtoa program. |
430
|
|
|
|
|
|
|
sub save { # Object method |
431
|
1
|
|
|
1
|
1
|
28
|
my $self = shift ; |
432
|
|
|
|
|
|
|
# my $class = ref( $self ) || $self ; |
433
|
|
|
|
|
|
|
|
434
|
1
|
|
33
|
|
|
5
|
my $file = shift() || $self->get( '-file' ) ; |
435
|
|
|
|
|
|
|
|
436
|
1
|
50
|
|
|
|
4
|
croak "save() no file specified" unless $file ; |
437
|
|
|
|
|
|
|
|
438
|
1
|
|
|
|
|
4
|
$self->set( '-file', $file ) ; |
439
|
|
|
|
|
|
|
|
440
|
1
|
|
|
|
|
12
|
my( $width, $height, $hotx, $hoty ) = |
441
|
|
|
|
|
|
|
$self->get( '-width', '-height', '-hotx', '-hoty' ) ; |
442
|
|
|
|
|
|
|
|
443
|
1
|
|
|
|
|
3
|
my $MASK1 = $MASK + 1 ; |
444
|
1
|
|
|
|
|
3
|
my $ROWSn1 = $ROWS - 1 ; |
445
|
|
|
|
|
|
|
|
446
|
1
|
|
|
|
|
7
|
my $fh = Symbol::gensym ; |
447
|
1
|
50
|
|
|
|
16753
|
open $fh, ">$file" or croak "save() failed to open `$file': $!" ; |
448
|
|
|
|
|
|
|
|
449
|
1
|
|
|
|
|
22
|
$file =~ s,^.*/,,o ; |
450
|
1
|
|
|
|
|
12
|
$file =~ s/\.xbm$//o ; |
451
|
1
|
|
|
|
|
5
|
$file =~ tr/[-_A-Za-z0-9]/_/c ; |
452
|
|
|
|
|
|
|
|
453
|
1
|
|
|
|
|
67
|
print $fh "#define ${file}_width $width\n#define ${file}_height $height\n" ; |
454
|
1
|
50
|
33
|
|
|
7
|
print $fh "#define ${file}_x_hot $hotx\n#define ${file}_y_hot $hoty\n" |
455
|
|
|
|
|
|
|
if $hotx > $UNSET and $hoty > $UNSET ; |
456
|
1
|
|
|
|
|
10
|
print $fh "static unsigned char ${file}_bits[] = {\n" ; |
457
|
|
|
|
|
|
|
|
458
|
1
|
|
|
|
|
5
|
my $padded = ( $width & $MASK ) != 0 ; |
459
|
1
|
|
|
|
|
3
|
my @char ; |
460
|
1
|
|
|
|
|
4
|
my $char = 0 ; |
461
|
1
|
|
|
|
|
8
|
for( my $y = 0 ; $y < $height ; $y++ ) { |
462
|
6
|
|
|
|
|
16
|
for( my $x = 0 ; $x < $width ; $x++ ) { |
463
|
30
|
|
|
|
|
37
|
my $mask = $x & $MASK ; |
464
|
30
|
100
|
|
|
|
57
|
$char[$char] = 0 unless defined $char[$char] ; |
465
|
30
|
100
|
|
|
|
174
|
$char[$char] |= $MASK[$mask] if $self->xybit( $x, $y ) ; |
466
|
30
|
50
|
|
|
|
97
|
$char++ if $mask == $MASK ; |
467
|
|
|
|
|
|
|
} |
468
|
6
|
50
|
|
|
|
18
|
$char++ if $padded ; |
469
|
|
|
|
|
|
|
} |
470
|
|
|
|
|
|
|
|
471
|
1
|
|
|
|
|
3
|
my $i = 0 ; |
472
|
1
|
|
|
|
|
11
|
my $bytes_per_char = ( $width + $MASK ) / $MASK1 ; |
473
|
1
|
|
|
|
|
4
|
foreach $char ( @char ) { |
474
|
6
|
|
|
|
|
23
|
printf $fh " 0x%02x", $char ; |
475
|
6
|
100
|
|
|
|
18
|
print $fh "," unless $i == $#char ; |
476
|
6
|
50
|
|
|
|
11
|
print $fh "\n" if $i % $ROWS == $ROWSn1 ; |
477
|
6
|
|
|
|
|
9
|
$i++ ; |
478
|
|
|
|
|
|
|
} |
479
|
1
|
|
|
|
|
4
|
print $fh " } ;\n"; |
480
|
|
|
|
|
|
|
|
481
|
1
|
50
|
|
|
|
82
|
close $fh or croak "save() failed to close `$file': $!" ; |
482
|
|
|
|
|
|
|
} |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
1 ; |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
__END__ |