Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # $Id: AttributedString.pm,v 1.9 2003/04/29 18:18:06 malay Exp $ Perl |
2 | # module for Pastel::Text::AttributedString | |
3 | # Author: Malay < curiouser@ccmb.res.in > | |
4 | # Copyright (c) 2003 Malay K Basu | |
5 | # You may distribute this module under the same terms as perl itself | |
6 | ||
7 | =head1 NAME | |
8 | ||
9 | Pastel::Text::AttributedString - For drawing text with attributes. | |
10 | ||
11 | =head1 SYNOPSIS | |
12 | ||
13 | $as = Pastel::Text::AttributedString->new(-text=>"Some text"); | |
14 | ||
15 | # create a font object | |
16 | $font = Pastel::Font->new(-family=>"Arial", -style=>"bold", -size=>14); | |
17 | ||
18 | # create a hash containing font | |
19 | $att{FONT} = $font; | |
20 | $att{X} = 100; | |
21 | $att{Y} = 200; | |
22 | ||
23 | ||
24 | $as1 = Pastel:: Text::AttributedString->new(-text=>"Some text", | |
25 | -attributes=> \%att); | |
26 | ||
27 | my $g = Pastel::Graphics->new(); | |
28 | ||
29 | # draw both the string | |
30 | $g->draw_string($as, 10, 20); | |
31 | ||
32 | # no x and y coordinates. Remember, we created the hash containing | |
33 | # coordinates | |
34 | $g->draw_string($as1); | |
35 | ||
36 | # set some attributes to $as. | |
37 | $as->add_attribute("COLOR", Pastel::Color->red, 0, 3); | |
38 | ||
39 | # draw the sting now | |
40 | $g->draw_string($as, 200, 300); | |
41 | ||
42 | ||
43 | =head1 DESCRIPTION | |
44 | ||
45 | SVG "tspan" elements are supported by this module. Unlike | |
46 | AttributedString class in Java, you do not pass | |
47 | AttributedCharacterIterator to the graphics context. But pass the | |
48 | AttributedString class itself. | |
49 | ||
50 | The following text attributes are defined and can be used with this module- | |
51 | ||
52 | ||
53 | FONT A Pastel::Font object | |
54 | ||
55 | FAMILY A string describing the family name of the font. If the | |
56 | FONT attibute is already set then this attribute is ignored. | |
57 | Should not be a composite of more than one attributes. e.g. | |
58 | "Arial" is a valid attibute value but "Arial-Bold" is not. | |
59 | ||
60 | POSTURE REGULAR or OBLIQUE or ITALIC | |
61 | ||
62 | WEIGHT REGULAR or BOLD. Default REGULAR. | |
63 | ||
64 | SIZE Point size. | |
65 | ||
66 | COLOR Pastel::Color object. | |
67 | ||
68 | UNDERLINE ON | |
69 | ||
70 | STRIKETHROUGH ON | |
71 | ||
72 | ANCHOR START or MIDDLE or END | |
73 | ||
74 | STROKE_WIDTH Numeric value denoting stroke-width in pixels | |
75 | ||
76 | STROKE_COLOR Pastel::Color object | |
77 | ||
78 | ROTATE Numeric value indicating the rotation of the glyph | |
79 | ||
80 | ||
81 | Note that X and Y coordinates are not valid attributes. | |
82 | ||
83 | Each AttributedString class contains the C<root> attribute, which is | |
84 | applied to the whole string. The are three ways to put this root | |
85 | attributes: (1) pass the attributes as hash in the construtor; (2) use | |
86 | the C<add_attribute()> method with only the first two arguments; (3) | |
87 | use C<add_attribute()> method with the first index 0 and the last | |
88 | index equals to the length of the whole string. | |
89 | ||
90 | In addition to the C<root> element the AttributedString contains | |
91 | several C<"runs">. Each run is represented by a single C<<tspan>> element. | |
92 | ||
93 | ||
94 | =head1 CONSTRUCTOR | |
95 | ||
96 | =head2 Pastel::Text::AttributedString->new(-text=>$string) | |
97 | ||
98 | Creates and returns an AttributedString object with no attributes defined. | |
99 | ||
100 | =head2 Pastel::Text::AttributedString->new(-text=>$string, -attributes=>\%att); | |
101 | ||
102 | Creates and returns an AttributedString object with attributes defined | |
103 | for the whole string.%att is a hash containing the attributes in key | |
104 | value pairs. | |
105 | ||
106 | =cut | |
107 | ||
108 | package Pastel::Text::AttributedString; | |
109 | ||
110 | @ISA = qw(Pastel::String Pastel::Mixin::Mixin); | |
111 | ||
112 | use Carp; | |
113 | use strict; | |
114 | ||
115 | #use Pastel::Mixin::Mixin; | |
116 | #use Pastel::Text; | |
117 | ||
118 | sub new { | |
119 | my $class = shift; | |
120 | ||
121 | # Fields | |
122 | ||
123 | my $self = { | |
124 | string => "", # to hold the string value | |
125 | runcount => 0, # Total number of runs | |
126 | string_length => 0, | |
127 | run_start_index => [], # holds the beginning index of each run | |
128 | run_end_index => [], # holds the end index of each run | |
129 | attributes => [], | |
130 | root_attribute => {}, | |
131 | valid_keys => [ | |
132 | "FONT", "FAMILY", "POSTURE", "WEIGHT", | |
133 | "SIZE", "COLOR", "UNDERLINE", "STRIKETHROUGH", | |
134 | "ANCHOR", "STROKE_WIDTH", "STROKE_COLOR", "X", | |
135 | "Y", "MULTI_X", "MULTI_Y", "ROTATE" | |
136 | ] | |
137 | }; | |
138 | bless $self, ref($class) || $class; | |
139 | $self->_init(@_); | |
140 | return $self; | |
141 | } | |
142 | ||
143 | sub _init { | |
144 | my ( $self, @args ) = @_; | |
145 | ||
146 | if ( @args < 1 || @args > 4 ) { | |
147 | croak "***Illegal parameters in Pastel::Text::AttributedString!\n"; | |
148 | } | |
149 | ||
150 | my ( $string, $attributes ) = | |
151 | $self->_rearrange( [ "TEXT", "ATTRIBUTES" ], @args ); | |
152 | ||
153 | if ( defined($string) ) { | |
154 | $self->{string} = $string; | |
155 | $self->{string_length} = length $string; | |
156 | ||
157 | } | |
158 | else { | |
159 | croak "Illegal parameter in Pastel::Text::AttributedString!\n"; | |
160 | } | |
161 | ||
162 | if ( defined($attributes) ) { | |
163 | my (@attribute); | |
164 | ||
165 | #print STDERR "Map supplied", "\n"; | |
166 | # Loop through the hash | |
167 | foreach my $key ( keys %{$attributes} ) { | |
168 | if ( $self->_valid_key($key) ) { | |
169 | push @attribute, $key, ${$attributes}{$key}; | |
170 | } | |
171 | } | |
172 | ||
173 | $self->_add_to_root_attribute(@attribute); | |
174 | } | |
175 | ||
176 | return $self; | |
177 | } | |
178 | ||
179 | =head1 METHODS | |
180 | ||
181 | =cut | |
182 | ||
183 | sub add_attribute { | |
184 | my $self = shift; | |
185 | my @args = @_; | |
186 | my $max_index = $self->{string_length} - 1; | |
187 | ||
188 | #my (@attributes) = $self->_get_attribute( $args[0], $args[1] ); | |
189 | ||
190 | unless ( $self->_valid_key( $args[0] ) ) { | |
191 | croak "Illegal Key in | |
192 | Pastel::Text::AttributedString::add_attribute!\n"; | |
193 | } | |
194 | ||
195 | if ( @args < 2 || @args > 4 ) { | |
196 | croak "Illegal parameter in | |
197 | Pastel:Text:AttributedString::add_attribute!\n"; | |
198 | ||
199 | } | |
200 | ||
201 | if ( @args == 2 ) { | |
202 | ||
203 | $self->_add_to_root_attribute( $args[0], $args[1] ); | |
204 | ||
205 | #print STDERR %{$self->{root_attribute}}, "\n"; | |
206 | ||
207 | } | |
208 | elsif ( scalar(@args) == 4 ) { | |
209 | ||
210 | #print STDERR "$args[2], $args[3]","\n"; | |
211 | ||
212 | if ( $args[2] > $args[3] ) { | |
213 | croak "Error in | |
214 | Pastel::Text::AttributedString::add_attribute\nBegin Index | |
215 | should be lesser than End Index!\n"; | |
216 | } | |
217 | ||
218 | elsif ($args[2] < 0 | |
219 | || $args[2] > $max_index | |
220 | || $args[3] < 0 | |
221 | || $args[3] > $max_index ) | |
222 | { | |
223 | croak | |
224 | "Out of range index in Pastel::Text::AttributedSring::add_attribut!\n"; | |
225 | ||
226 | } | |
227 | ||
228 | # check whether the attributes cover the whole string | |
229 | elsif ( $args[2] == 0 && $args[3] == $max_index ) { | |
230 | ||
231 | #my (@attributes) = $self->_get_attribute($args[0], $args[1]); | |
232 | $self->_add_to_root_attribute( $args[0], $args[1] ); | |
233 | return; | |
234 | ||
235 | } | |
236 | ||
237 | elsif ( $self->{runcount} == 0 ) { | |
238 | ||
239 | #print STDERR "****Runcount 0\n"; | |
240 | $self->_create_new_run(@args); | |
241 | ||
242 | } | |
243 | ||
244 | else { | |
245 | ||
246 | $self->_break_run(@args); | |
247 | ||
248 | } | |
249 | } # parameter 4 | |
250 | } | |
251 | ||
252 | sub to_svg { | |
253 | my $self = shift; | |
254 | ||
255 | my $s = "<text x=\"" . $self->get_x() . '" y="' . $self->get_y() . '"'; | |
256 | ||
257 | # we need to split the string to get splices | |
258 | my (@string) = split ( //, $self->{string} ); | |
259 | ||
260 | #my (@root_attr) = $self->_get_root_attributes(); | |
261 | #print STDERR "to_svg: @root_attr\n"; | |
262 | # _get_root_attributes() will return undef if there is no root attribute | |
263 | if ( $self->_get_root_attributes() ) { | |
264 | ||
265 | #if ( $self->_get_root_attributes()) { | |
266 | #print STDERR "***to_svg: root attribute present\n"; | |
267 | my (@root_attr) = $self->_get_root_attributes(); | |
268 | $s .= " style=\""; | |
269 | $s .= $self->_get_attributes_as_style(@root_attr); | |
270 | $s .= "\""; | |
271 | } | |
272 | $s .= '>'; | |
273 | ||
274 | # do we have any attribute set at all? | |
275 | if ( $self->{runcount} > 0 ) { | |
276 | ||
277 | # loop through each run and add it as <tspan> | |
278 | for ( my $i = 0 ; $i < $self->{runcount} ; $i++ ) { | |
279 | ||
280 | if ( $self->_get_run_attributes_as_array($i) ) { | |
281 | my (@run_attributes) = $self->_get_run_attributes_as_array($i); | |
282 | $s .= "<tspan style=\""; | |
283 | $s .= $self->_get_attributes_as_style(@run_attributes); | |
284 | $s .= '">'; | |
285 | } | |
286 | ||
287 | #print STDERR "***", ${ $self->{run_start_index} }[$i], ${ $self->{run_end_index}}[$i], "\n"; | |
288 | #print STDERR "***", @string[1..3], "\n"; | |
289 | ||
290 | my $text = join "", @string[ ${ $self->{run_start_index} }[$i] | |
291 | .. ${ $self->{run_end_index} }[$i] ]; | |
292 | ||
293 | # if ( ${ $self->{attributes} }[$i] ) { | |
294 | # $s .= '">'; | |
295 | # } | |
296 | # convert the xml entities | |
297 | $s .= $self->xml($text); | |
298 | ||
299 | if ( ${ $self->{attributes} }[$i] ) { | |
300 | $s .= '</tspan>'; | |
301 | } | |
302 | ||
303 | } | |
304 | } | |
305 | else { $s .= $self->{string}; } | |
306 | ||
307 | $s .= '</text>'; | |
308 | ||
309 | #print STDERR "to_svg: $s\n"; | |
310 | return $s; | |
311 | } | |
312 | ||
313 | =head1 PRIVATE METHODS | |
314 | ||
315 | =head2 _create_new_run($key, $value, $start, $end) | |
316 | ||
317 | If there is no run present this method actually creates a new run. Should be called when $self->{runcount} = 0. | |
318 | ||
319 | Returns : Nothing. | |
320 | Arguments: Same as add_attribute() | |
321 | ||
322 | =cut | |
323 | ||
324 | sub _create_new_run { | |
325 | my ( $self, @args ) = @_; | |
326 | my $max_index = $self->{string_length} - 1; | |
327 | ||
328 | my (%attrib) = ( $args[0], $args[1] ); | |
329 | ||
330 | if ( ( $args[2] > 0 ) && $args[3] < $max_index ) { | |
331 | ||
332 | #print STDERR "****Inside range\n"; | |
333 | ||
334 | #print STDERR "*** Attributes@attributes\n"; | |
335 | ||
336 | push @{ $self->{run_start_index} }, 0, $args[2], $args[3] + 1; | |
337 | push @{ $self->{run_end_index} }, $args[2] - 1, $args[3], $max_index; | |
338 | push @{ $self->{attributes} }, "", \%attrib, ""; | |
339 | $self->{runcount} += 3; | |
340 | ||
341 | return; | |
342 | } | |
343 | elsif ( $args[2] == 0 && $args[3] < $max_index ) { | |
344 | push @{ $self->{run_start_index} }, $args[2], $args[3] + 1; | |
345 | push @{ $self->{run_end_index} }, $args[3], $max_index; | |
346 | push @{ $self->{attributes} }, \%attrib, ""; | |
347 | $self->{runcount} += 2; | |
348 | } | |
349 | elsif ( $args[2] > 0 && $args[3] == $max_index ) { | |
350 | ||
351 | #print STDERR "***Run extends to the end\n"; | |
352 | ||
353 | push @{ $self->{run_start_index} }, 0, $args[2]; | |
354 | push @{ $self->{run_end_index} }, $args[2] - 1, $max_index; | |
355 | push @{ $self->{attributes} }, "", \%attrib; | |
356 | $self->{runcount} += 2; | |
357 | } | |
358 | ||
359 | } | |
360 | ||
361 | =head2 _break_run() | |
362 | ||
363 | Describe your function here | |
364 | ||
365 | Returns : | |
366 | Arguments: | |
367 | ||
368 | =cut | |
369 | ||
370 | sub _break_run { | |
371 | my ( $self, @args ) = @_; | |
372 | my @new_start; | |
373 | my @new_end; | |
374 | my @new_attrib; | |
375 | my $new_count; | |
376 | my $run_start_index = $self->_which_run( $args[2] ); | |
377 | my (@attributes) = ( $args[0], $args[1] ); | |
378 | ||
379 | if ( $run_start_index != 0 ) { # if not in the first run | |
380 | ||
381 | # fill up the new array with the data upto this point | |
382 | for ( my $i = 0 ; $i < $run_start_index ; $i++ ) { | |
383 | ||
384 | push ( @new_start, $self->_get_run_start($i) ); | |
385 | push ( @new_end, $self->_get_run_end($i) ); | |
386 | push ( @new_attrib, ${ $self->{attributes} }[$i] ); | |
387 | ||
388 | } | |
389 | ||
390 | } | |
391 | ||
392 | my $begin_offset = $args[2]; | |
393 | ||
394 | for ( my $i = $run_start_index ; $i < $self->{runcount} ; $i++ ) { | |
395 | ||
396 | my $begin_index = $self->_get_run_start($i); | |
397 | my $end_index = $self->_get_run_end($i); | |
398 | ||
399 | if ( $begin_index > $args[3] ) { | |
400 | push ( @new_start, $begin_index ); | |
401 | push ( @new_end, $end_index ); | |
402 | push ( @new_attrib, ${ $self->{attributes} }[$i] ); | |
403 | ||
404 | } | |
405 | elsif ($begin_index == $begin_offset | |
406 | && $end_index <= $args[3] ) | |
407 | { | |
408 | push ( @new_start, $begin_index ); | |
409 | push ( @new_end, $end_index ); | |
410 | push ( @new_attrib, | |
411 | $self->_get_spliced_attributes( $i, @attributes ) ); | |
412 | ||
413 | #print STDERR "***Inside\n"; | |
414 | ||
415 | # update the begin offset to start of the next run | |
416 | if ( defined $self->_get_run_start( $i + 1 ) ) { | |
417 | $begin_offset = $self->_get_run_start( $i + 1 ); | |
418 | ||
419 | #print STDERR "Begin offset: $begin_offset\n"; | |
420 | ||
421 | } | |
422 | ||
423 | } | |
424 | elsif ($begin_index == $begin_offset | |
425 | && $end_index > $args[3] ) | |
426 | { | |
427 | push ( @new_start, $begin_index, $args[3] + 1 ); | |
428 | push ( @new_end, $args[3], $end_index ); | |
429 | push ( @new_attrib, | |
430 | $self->_get_spliced_attributes( $i, @attributes ) ); | |
431 | push ( @new_attrib, ${ $self->{attributes} }[$i] ); | |
432 | ||
433 | } | |
434 | elsif ($begin_index < $begin_offset | |
435 | && $end_index > $args[3] ) | |
436 | { | |
437 | push ( @new_start, $begin_index, $begin_offset, $args[3] + 1 ); | |
438 | push ( @new_end, $begin_offset - 1, $args[3], $end_index ); | |
439 | push ( @new_attrib, ${ $self->{attributes} }[$i] ); | |
440 | push ( @new_attrib, | |
441 | $self->_get_spliced_attributes( $i, @attributes ) ); | |
442 | push ( @new_attrib, ${ $self->{attributes} }[$i] ); | |
443 | ||
444 | } | |
445 | elsif ($begin_index < $begin_offset | |
446 | && $end_index <= $args[3] ) | |
447 | { | |
448 | push ( @new_start, $begin_index, $begin_offset ); | |
449 | push ( @new_end, $begin_offset - 1, $end_index ); | |
450 | push ( @new_attrib, ${ $self->{attributes} }[$i] ); | |
451 | push ( @new_attrib, | |
452 | $self->_get_spliced_attributes( $i, @attributes ) ); | |
453 | ||
454 | if ( defined $self->_get_run_start( $i + 1 ) ) { | |
455 | $begin_offset = $self->_get_run_start( $i + 1 ); | |
456 | ||
457 | } | |
458 | ||
459 | } | |
460 | ||
461 | #print STDERR "***Runcount: $self->{runcount}","\n"; | |
462 | } #for loop | |
463 | ||
464 | $self->{run_start_index} = \@new_start; | |
465 | $self->{run_end_index} = \@new_end; | |
466 | $self->{attributes} = \@new_attrib; | |
467 | $self->{runcount} = @new_start; | |
468 | ||
469 | #print STDERR "New start: @new_start\n"; | |
470 | #print STDERR "New end : @new_end\n"; | |
471 | #print STDERR "@new_attrib\n"; | |
472 | ||
473 | } | |
474 | ||
475 | #sub _check_attribute { | |
476 | # my $self = shift; | |
477 | # my @args = @_; | |
478 | ||
479 | # if ($args[0] ne "FONT" && | |
480 | # $args[0] ne "FAMILY" && | |
481 | # $args[0] ne "POSTURE" && | |
482 | # $args[0] ne "WEIGHT" && | |
483 | # $args[0] ne "SIZE" && | |
484 | # $args[0] ne "COLOR" && | |
485 | # $args[0] ne "UNDERLINE" && | |
486 | # $args[0] ne "STRIKETHROUGH" && | |
487 | # $args[0] ne "ANCHOR" && | |
488 | # $args[0] ne "STROKE_WIDTH" && | |
489 | # $args[0] ne "STROKE_COLOR" | |
490 | # ){ | |
491 | # croak "Illegal parameter in Pastel::AttributedString::_check_attribute!\n"; | |
492 | ||
493 | # }else { | |
494 | # return 1; | |
495 | ||
496 | # } | |
497 | #} | |
498 | ||
499 | sub _get_attribute { | |
500 | my $self = shift; | |
501 | my ( $key, $value ) = @_; | |
502 | ||
503 | #print STDERR "get_attribute: $key, $value\n"; | |
504 | ||
505 | my @return_array; | |
506 | ||
507 | if ( $key eq "FONT" ) { | |
508 | push @return_array, "font-family"; | |
509 | push @return_array, $value->get_family(); | |
510 | ||
511 | if ( $value->get_style() eq "bold" ) { | |
512 | ||
513 | push @return_array, "font-weight"; | |
514 | push @return_array, "bold"; | |
515 | ||
516 | } | |
517 | elsif ( $value->get_style() eq "bolditalic" ) { | |
518 | push @return_array, "font-weight", "bold", "font-style", "italic"; | |
519 | } | |
520 | elsif ( $value->get_style() eq "italic" ) { | |
521 | push @return_array, "font-style", "italic"; | |
522 | ||
523 | } | |
524 | my $fs = $value->get_size()."pt"; | |
525 | push @return_array, "font-size", $fs; | |
526 | ||
527 | } | |
528 | elsif ( $key eq "COLOR" ) { | |
529 | push @return_array, "fill", $value->to_hex(); | |
530 | if ( $value->get_alpha() ) { | |
531 | push @return_array, "fill-opacity", $value->get_alpha(); | |
532 | ||
533 | } | |
534 | } | |
535 | elsif ( $key eq "FAMILY" ) { | |
536 | push @return_array, "font-family", $value; | |
537 | ##print STDERR "Entered test\n"; | |
538 | ||
539 | } | |
540 | elsif ( $key eq "POSTURE" ) { | |
541 | if ( $value eq "ITALIC" ) { | |
542 | push @return_array, "font-style", "italic"; | |
543 | ||
544 | } | |
545 | if ( $value eq "OBLIQUE" ) { | |
546 | push @return_array, "font-style", "oblique"; | |
547 | ||
548 | } | |
549 | ||
550 | } | |
551 | elsif ( $key eq "WEIGHT" ) { | |
552 | if ( $value eq "BOLD" ) { | |
553 | push @return_array, "font-weight", "bold"; | |
554 | ||
555 | } | |
556 | } | |
557 | elsif ( $key eq "SIZE" ) { | |
558 | push @return_array, "font-size", $value; | |
559 | ||
560 | } | |
561 | elsif ( $key eq "UNDERLINE" ) { | |
562 | push @return_array, "text-decoration", "underline"; | |
563 | ||
564 | } | |
565 | elsif ( $key eq "STRIKETHROUGH" ) { | |
566 | push @return_array, "text-decoration", "line-through"; | |
567 | ||
568 | } | |
569 | elsif ( $key eq "STROKE_COLOR" ) { | |
570 | push @return_array, "stroke", $value->to_hex(); | |
571 | if ( $value->get_alpha() ) { | |
572 | push @return_array, "stroke-opacity", $value->get_alpha(); | |
573 | ||
574 | } | |
575 | } | |
576 | elsif ( $key eq "STROKE_WIDTH" ) { | |
577 | push @return_array, "stroke-width", $value; | |
578 | ||
579 | } | |
580 | elsif ( $key eq "ANCHOR" ) { | |
581 | push @return_array, "text-anchor", lc($value); | |
582 | ||
583 | } | |
584 | ||
585 | # elsif ( $key eq "X" ) { | |
586 | # push @return_array, "x", $value; | |
587 | # } | |
588 | # elsif ( $key eq "Y" ) { | |
589 | # push @return_array, "y", $value; | |
590 | ||
591 | # } | |
592 | # elsif ( $key eq "MULTI_X" ) { | |
593 | # push @return_array, "x", $value; | |
594 | ||
595 | # } | |
596 | # elsif ( $key eq "MULTI_Y" ) { | |
597 | # push @return_array, "y", $value; | |
598 | ||
599 | # } | |
600 | elsif ( $key eq "ROTATE" ) { | |
601 | push @return_array, "rotate", $value; | |
602 | ||
603 | } | |
604 | ||
605 | # elsif ( $key eq "DX" ) { | |
606 | # push @return_array, "dx", $value; | |
607 | ||
608 | # } | |
609 | # elsif ( $key eq "DY" ) { | |
610 | # push @return_array, "dy", $value; | |
611 | ||
612 | # } | |
613 | # elsif ( $key eq "MULTI_DX" ) { | |
614 | # push @return_array, "dx", $value; | |
615 | ||
616 | # } | |
617 | # elsif ( $key eq "MULTI_DY" ) { | |
618 | # push @return_array, "dy", $value; | |
619 | ||
620 | # } | |
621 | #print STDERR "get_attribute:@return_array\n"; | |
622 | return @return_array; | |
623 | ||
624 | } | |
625 | ||
626 | sub _add_to_root_attribute { | |
627 | my $self = shift; | |
628 | my @attributes = @_; | |
629 | ||
630 | #print STDERR "***@attributes\n"; | |
631 | ||
632 | #my (%root_attribute) = (%{ $self->{root_attribute} }); | |
633 | ||
634 | for ( my $i = 0 ; $i < @attributes ; $i += 2 ) { | |
635 | ${ $self->{root_attribute} }{ $attributes[$i] } = $attributes[ $i + 1 ]; | |
636 | ##print STDERR "Inside loop\n"; | |
637 | ||
638 | } | |
639 | ||
640 | #$self->{root_attribute} = \%root_attribute; | |
641 | #my (@array) = (%{$self->{root_attribure}}); | |
642 | #print STDERR "add_to_root:@array\n"; | |
643 | } | |
644 | ||
645 | sub _which_run { | |
646 | my $self = shift; | |
647 | my $index = shift; | |
648 | ||
649 | for ( my $i = 0 ; $i < $self->{runcount} ; $i++ ) { | |
650 | if ( $index >= ${ $self->{run_start_index} }[$i] | |
651 | && $index <= ${ $self->{run_end_index} }[$i] ) | |
652 | { | |
653 | return $i; | |
654 | ||
655 | } | |
656 | } | |
657 | } | |
658 | ||
659 | sub _is_inside { | |
660 | my $self = shift; | |
661 | my ( $run, $index ) = @_; | |
662 | if ( $index >= ${ $self->{run_start_index} }[$run] | |
663 | && $index <= ${ $self->{run_end_index} }[$run] ) | |
664 | { | |
665 | return 1; | |
666 | ||
667 | } | |
668 | else { | |
669 | return undef; | |
670 | ||
671 | } | |
672 | ||
673 | } | |
674 | ||
675 | sub _get_run_start { | |
676 | ||
677 | my $self = shift; | |
678 | my $index = shift; | |
679 | if ( $index < $self->{runcount} ) { | |
680 | ||
681 | return ${ $self->{run_start_index} }[$index]; | |
682 | } | |
683 | else { | |
684 | return undef; | |
685 | ||
686 | } | |
687 | } | |
688 | ||
689 | sub _get_run_end { | |
690 | my $self = shift; | |
691 | my $index = shift; | |
692 | return ${ $self->{run_end_index} }[$index]; | |
693 | ||
694 | } | |
695 | ||
696 | sub _get_root_attributes { | |
697 | ||
698 | my $self = shift; | |
699 | ||
700 | if ( %{ $self->{root_attribute} } ) { | |
701 | ||
702 | #print STDERR "get_root_attributes:***Root attribute present\n"; | |
703 | #print STDERR %{$self->{root_attributes}}, "\n"; | |
704 | #my %attribute_hash = %{$self->{root_attributes}}; | |
705 | my @array; | |
706 | ||
707 | foreach my $key ( keys %{ $self->{root_attribute} } ) { | |
708 | ||
709 | #print STDERR "get_root_attributes: inside foreach loop\n"; | |
710 | #print STDERR "get_root_attributes: $key:".${$self->{root_attribute}}{$key}."\n"; | |
711 | push @array, | |
712 | $self->_get_attribute( $key, ${ $self->{root_attribute} }{$key} ); | |
713 | ||
714 | } | |
715 | ||
716 | #print STDERR "get_root_attributes: @array", "\n"; | |
717 | return @array; | |
718 | ||
719 | } | |
720 | else { return undef } | |
721 | ||
722 | } | |
723 | ||
724 | sub _get_run_attributes { | |
725 | my $self = shift; | |
726 | my $index = shift; | |
727 | my @array; | |
728 | ||
729 | if ( ${ $self->{attributes} }[$index] ) { | |
730 | ||
731 | my %attribute_hash = %{ ${ $self->{attributes} }[$index] }; | |
732 | ||
733 | foreach my $key ( keys %attribute_hash ) { | |
734 | ||
735 | push @array, $self->_get_attribute( $key, $attribute_hash{$key} ); | |
736 | ||
737 | } | |
738 | ||
739 | my (%array) = (@array); | |
740 | return \%array; | |
741 | } | |
742 | else { return undef; } | |
743 | ||
744 | } | |
745 | ||
746 | sub _get_run_attributes_as_array { | |
747 | my $self = shift; | |
748 | my $index = shift; | |
749 | my $att = $self->_get_run_attributes($index); | |
750 | my @a; | |
751 | if ($att) { | |
752 | ||
753 | foreach my $key ( keys %{$att} ) { | |
754 | push @a, $key, ${$att}{$key}; | |
755 | ||
756 | } | |
757 | return @a; | |
758 | ||
759 | } | |
760 | else { | |
761 | return undef; | |
762 | ||
763 | } | |
764 | } | |
765 | ||
766 | sub _get_spliced_attributes { | |
767 | ||
768 | my $self = shift; | |
769 | my $index = shift; | |
770 | my (@new_attributes) = @_; | |
771 | my (%new_hash); | |
772 | ||
773 | #print STDERR "***Inside splice $index\n"; | |
774 | if ( ${ $self->{attributes} }[$index] ) { | |
775 | ||
776 | #print STDERR "***Inside splice $index\n"; | |
777 | (%new_hash) = ( %{ ${ $self->{attributes} }[$index] } ); | |
778 | } | |
779 | ||
780 | for ( my $i = 0 ; $i < @new_attributes ; $i += 2 ) { | |
781 | $new_hash{ $new_attributes[$i] } = $new_attributes[ $i + 1 ]; | |
782 | ||
783 | } | |
784 | ||
785 | return \%new_hash; | |
786 | ||
787 | # foreach my $key (keys %new_hash){ | |
788 | # print STDERR "***Hash key: ".$key.":".$new_hash{$key}."\n"; | |
789 | # } | |
790 | ||
791 | } | |
792 | ||
793 | =head2 _valid_key($string) | |
794 | ||
795 | Validate the string whether it is a legal C<key> or not. The function | |
796 | loops through the array in C<valid_keys> attribute and returns true, | |
797 | if it is present or false it it is not. | |
798 | ||
799 | Returns : 1 if $string is a valid key or return C<undef>. | |
800 | Arguments: A string. | |
801 | ||
802 | =cut | |
803 | ||
804 | sub _valid_key { | |
805 | my ( $self, $string ) = @_; | |
806 | ||
807 | my $return = undef; | |
808 | ||
809 | foreach my $key ( @{ $self->{valid_keys} } ) { | |
810 | if ( $key eq $string ) { | |
811 | $return = 1; | |
812 | last; | |
813 | ||
814 | } | |
815 | } | |
816 | ||
817 | return $return; | |
818 | } | |
819 | ||
820 | =head2 _get_attributes_as_style() | |
821 | ||
822 | Describe your function here | |
823 | ||
824 | Returns : | |
825 | Arguments: | |
826 | ||
827 | =cut | |
828 | ||
829 | sub _get_attributes_as_style { | |
830 | ||
831 | my ( $self, @args ) = @_; | |
832 | my $s = ""; | |
833 | ||
834 | #print STDERR "@args\n"; | |
835 | for ( my $i = 0 ; $i < @args ; $i += 2 ) { | |
836 | $s .= $args[$i] . ':' . $args[ $i + 1 ]; | |
837 | if ( $i < ( @args - 2 ) ) { | |
838 | $s .= ';'; | |
839 | ||
840 | } | |
841 | } | |
842 | ||
843 | return $s; | |
844 | ||
845 | } | |
846 | ||
847 | =head1 CONTACT | |
848 | ||
849 | Malay <curiouser@ccmb.res.in> | |
850 | ||
851 | =cut | |
852 | ||
853 | 1; |