[system] / trunk / pg / lib / Label.pm Repository:
ViewVC logotype

Annotation of /trunk/pg/lib/Label.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 6346 - (view) (download) (as text)

1 : sh002i 1050 =head1 NAME
2 :    
3 :     Label
4 :    
5 :    
6 :     =head1 SYNPOSIS
7 :    
8 :     use Carp;
9 :     use GD;
10 :     use WWPlot;
11 :     use Fun;
12 :    
13 :    
14 :     =head1 DESCRIPTION
15 :    
16 :     This module defines labels for the graph objects (WWPlot).
17 :    
18 :    
19 :     =head2 Usage
20 :    
21 :     $label1 = new Label($x_value, $y_value, $label_string, $label_color, @justification)
22 :     $justification = one of ('left', 'center', 'right) and ('bottom', 'center', 'top')
23 :     describes the position of the ($x_value, $y_value) within the string.
24 :     The default is 'left', 'top'
25 :    
26 :    
27 :    
28 :     =head2 Example
29 :    
30 :     $new_label = new Label ( 0,0, 'origin','red','left', 'top')
31 :     @labels = $graph->lb($new_label);
32 :    
33 :    
34 :    
35 :     =cut
36 :    
37 :    
38 :     BEGIN {
39 :     be_strict(); # an alias for use strict. This means that all global variable must contain main:: as a prefix.
40 :     }
41 :     package Label;
42 :     use strict;
43 :     #use Exporter;
44 :     #use DynaLoader;
45 :     #use GD; # this is needed to be able to define GD::gdMediumBoldFont and other terms used by GD
46 :     # # however constants from GD need to be addressed fully, they have not been imported.
47 :     #use "WWPlot.pm";
48 :     #Because of the way problem modules are loaded 'use' is disabled.
49 :    
50 :    
51 :     @Label::ISA = qw(WWPlot);
52 :    
53 :     my %fields =(
54 :     'x' => 0,
55 :     'y' => 0,
56 :     color => 'black',
57 :     font => GD::gdMediumBoldFont, #gdLargeFont
58 :     # constants from GD need to be addressed fully, they have not been imported.
59 :     str => "",
60 :     lr_nudge => 0, #justification parameters
61 :     tb_nudge => 0,
62 :     );
63 :    
64 :    
65 :     sub new {
66 :     my $class = shift;
67 :     my $self = {
68 :     %fields,
69 :     };
70 :    
71 :     bless $self, $class;
72 :     $self->_initialize(@_);
73 :     return $self;
74 :     }
75 :    
76 :     sub _initialize {
77 :     my $self = shift;
78 :     my ($x,$y,$str,$color,@justification) = @_;
79 :     $self -> x($x);
80 :     $self -> y($y);
81 :     $self -> str($str);
82 :     $self -> color($color) if defined($color);
83 :     my $j;
84 :     foreach $j (@justification) {
85 :     $self->lr_nudge( - length($self->str) ) if $j eq 'right';
86 :     $self->tb_nudge( - 1 ) if $j eq 'bottom';
87 :     $self->lr_nudge( - ( length($self->str) )/2)if $j eq 'center';
88 :     $self->tb_nudge(-0.5) if $j eq 'middle';
89 :     # print "\njustification=$j",$self->lr_nudge,$self->tb_nudge,"\n";
90 :     }
91 :     }
92 :     sub draw {
93 :     my $self = shift;
94 :     my $g = shift; #the containing graph
95 :     $g->im->string( $self->font,
96 :     $g->ii($self->x)+int( $self->lr_nudge*($self->font->width) ),
97 :     $g->jj($self->y)+int( $self->tb_nudge*($self->font->height) ),
98 :     $self->str,
99 :     ${$g->colors}{$self->color}
100 :     );
101 :    
102 :     }
103 :    
104 :     sub AUTOLOAD {
105 :     my $self = shift;
106 :     my $type = ref($self) || die "$self is not an object";
107 :     my $name = $Label::AUTOLOAD;
108 :     $name =~ s/.*://; # strip fully-qualified portion
109 :     unless (exists $self->{'_permitted'}->{$name} ) {
110 :     die "Can't find '$name' field in object of class $type";
111 :     }
112 :     if (@_) {
113 :     return $self->{$name} = shift;
114 :     } else {
115 :     return $self->{$name};
116 :     }
117 :    
118 :     }
119 :    
120 : gage 6346 ##########################
121 :     # Access methods
122 :     ##########################
123 :     sub x {
124 :     my $self = shift;
125 :     my $type = ref($self) || die "$self is not an object";
126 :     unless (exists $self->{x} ) {
127 :     die "Can't find x field in object of class $type";
128 :     }
129 :    
130 :     if (@_) {
131 :     return $self->{x} = shift;
132 :     } else {
133 :     return $self->{x}
134 :     }
135 :     }
136 :    
137 :     sub y {
138 :     my $self = shift;
139 :     my $type = ref($self) || die "$self is not an object";
140 :     unless (exists $self->{y} ) {
141 :     die "Can't find y field in object of class $type";
142 :     }
143 :    
144 :     if (@_) {
145 :     return $self->{y} = shift;
146 :     } else {
147 :     return $self->{y}
148 :     }
149 :     }
150 :    
151 :     sub color {
152 :     my $self = shift;
153 :     my $type = ref($self) || die "$self is not an object";
154 :     unless (exists $self->{color} ) {
155 :     die "Can't find color field in object of class $type";
156 :     }
157 :    
158 :     if (@_) {
159 :     return $self->{color} = shift;
160 :     } else {
161 :     return $self->{color}
162 :     }
163 :     }
164 :     sub font {
165 :     my $self = shift;
166 :     my $type = ref($self) || die "$self is not an object";
167 :     unless (exists $self->{font} ) {
168 :     die "Can't find font field in object of class $type";
169 :     }
170 :    
171 :     if (@_) {
172 :     return $self->{font} = shift;
173 :     } else {
174 :     return $self->{font}
175 :     }
176 :     }
177 :     sub str {
178 :     my $self = shift;
179 :     my $type = ref($self) || die "$self is not an object";
180 :     unless (exists $self->{str} ) {
181 :     die "Can't find str field in object of class $type";
182 :     }
183 :    
184 :     if (@_) {
185 :     return $self->{str} = shift;
186 :     } else {
187 :     return $self->{str}
188 :     }
189 :     }
190 :     sub lr_nudge {
191 :     my $self = shift;
192 :     my $type = ref($self) || die "$self is not an object";
193 :     unless (exists $self->{lr_nudge} ) {
194 :     die "Can't find lr_nudge field in object of class $type";
195 :     }
196 :    
197 :     if (@_) {
198 :     return $self->{lr_nudge} = shift;
199 :     } else {
200 :     return $self->{lr_nudge}
201 :     }
202 :     }
203 :    
204 :     sub tb_nudge {
205 :     my $self = shift;
206 :     my $type = ref($self) || die "$self is not an object";
207 :     unless (exists $self->{tb_nudge} ) {
208 :     die "Can't find tb_nudge field in object of class $type";
209 :     }
210 :    
211 :     if (@_) {
212 :     return $self->{tb_nudge} = shift;
213 :     } else {
214 :     return $self->{tb_nudge}
215 :     }
216 :     }
217 : sh002i 1050 sub DESTROY {
218 :     # doing nothing about destruction, hope that isn't dangerous
219 :     }
220 :    
221 :     1;
222 :    
223 :    
224 :    

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9