File Coverage

blib/lib/CPU/Z80/Disassembler/Label.pm
Criterion Covered Total %
statement 40 40 100.0
branch 16 16 100.0
condition 8 8 100.0
subroutine 11 11 100.0
pod 5 5 100.0
total 80 80 100.0


line stmt bran cond sub pod time code
1             package CPU::Z80::Disassembler::Label;
2              
3             #------------------------------------------------------------------------------
4              
5             =head1 NAME
6              
7             CPU::Z80::Disassembler::Label - Label used in the disassembled program
8              
9             =cut
10              
11             #------------------------------------------------------------------------------
12              
13 8     8   889 use strict;
  8         15  
  8         208  
14 8     8   46 use warnings;
  8         14  
  8         175  
15              
16 8     8   35 use Carp;
  8         12  
  8         361  
17              
18 8     8   1213 use CPU::Z80::Disassembler::Format;
  8         27  
  8         525  
19              
20             our $VERSION = '1.02';
21              
22             #------------------------------------------------------------------------------
23              
24             =head1 SYNOPSYS
25              
26             $label = CPU::Z80::Disassembler::Label->new($addr, $name, @from_addr);
27             $label->add_refer(@from_addr);
28             my @refer = $label->refer_from;
29             print $label->label_string;
30             print $label->equ_string;
31              
32             =head1 DESCRIPTION
33              
34             Represents one label in the disassembled program. The label contains a name, an
35             address and a list of addresses of opcodes that refer to it.
36              
37             =head1 FUNCTIONS
38              
39             =head2 new
40              
41             Creates a new object.
42              
43             =head2 name
44              
45             Gets/sets the label name.
46              
47             =head2 comment
48              
49             Gets/sets the comment to add to the definition of the label.
50              
51             =head2 addr
52              
53             Gets the label address. The address cannot be modified.
54              
55             =cut
56              
57             #------------------------------------------------------------------------------
58 8     8   51 use base 'Class::Accessor';
  8         14  
  8         4014  
59             __PACKAGE__->mk_accessors(
60             'name', # name
61             'comment', # comment to add to label when defining
62             'addr', # address
63             '_refer', # hash of reference address
64             );
65              
66             sub new {
67 2102     2102 1 8394 my($class, $addr, $name, @from_addr) = @_;
68 2102 100 100     10384 croak("invalid name".(defined($name) ? " '$name'" : ""))
    100          
69             unless defined($name) && $name =~ /^[a-z_]\w*$/i;
70 2100 100 100     9074 croak("invalid address".(defined($addr) ? " '$addr'" : ""))
    100          
71             unless defined($addr) && $addr =~ /^\d+$/;
72            
73 2098         9336 my $self = bless { name => $name, addr => $addr,
74             _refer => {},
75             }, $class;
76 2098 100       4771 $self->add_refer(@from_addr) if @from_addr;
77 2098         5174 return $self;
78             }
79             #------------------------------------------------------------------------------
80              
81             =head2 add_refer
82              
83             Add the given addresses as references to this label, i.e. places from where
84             this label is used.
85              
86             =cut
87              
88             #------------------------------------------------------------------------------
89             sub add_refer {
90 3342     3342 1 8775 my($self, @from_addr) = @_;
91 3342         9835 $self->_refer->{$_}++ for (@from_addr);
92             }
93              
94             #------------------------------------------------------------------------------
95              
96             =head2 refer_from
97              
98             Return the list of all addresses from which this label is used.
99              
100             =cut
101              
102             #------------------------------------------------------------------------------
103             sub refer_from {
104 11     11 1 5348 my($self) = @_;
105 11         18 return sort {$a <=> $b} keys %{$self->_refer};
  11         107  
  11         23  
106             }
107              
108             #------------------------------------------------------------------------------
109              
110             =head2 label_string
111              
112             Returns the string to be used in an assembly file to define this label
113             at the current location counter:
114              
115             LABEL: ; COMMENT
116              
117             =cut
118              
119             #------------------------------------------------------------------------------
120             sub label_string {
121 1918     1918 1 7090 my($self) = @_;
122 1918         3802 my $opcode = $self->name.":";
123 1918         18512 return $self->_format_comment($opcode)."\n";
124             }
125             #------------------------------------------------------------------------------
126              
127             =head2 equ_string
128              
129             Returns the string to be used in an assembly file to define this label
130             as a constant:
131              
132             LABEL equ ADDR ; COMMENT
133              
134             =cut
135              
136             #------------------------------------------------------------------------------
137             sub equ_string {
138 133     133 1 205 my($self, $field_width) = @_;
139 133   100     226 $field_width ||= 12;
140 133         227 my $opcode = sprintf("%-*s equ %s", $field_width-1, $self->name,
141             format_hex4($self->addr));
142 133         270 return $self->_format_comment($opcode)."\n";
143             }
144              
145             sub _format_comment {
146 2051     2051   3745 my($self, $opcode) = @_;
147            
148 2051         3939 my $comment = $self->comment;
149 2051 100       18077 if (defined $comment) {
150 136         285 $comment =~ s/\n/ "\n" . " " x 32 . "; " /ge; # multi-line comment
  61         147  
151             }
152            
153 2051 100       7653 return !defined($comment) ?
    100          
154             $opcode :
155             length($opcode) >= 32 ?
156             $opcode . "\n" . " " x 32 . "; " . $comment :
157             sprintf("%-32s; %s", $opcode, $comment);
158             }
159              
160             #------------------------------------------------------------------------------
161              
162             =head1 BUGS, FEEDBACK, AUTHORS, COPYRIGHT and LICENCE
163              
164             See L.
165              
166             =cut
167              
168             1;