File Coverage

blib/lib/Excel/Writer/XLSX/Shape.pm
Criterion Covered Total %
statement 109 111 98.2
branch 12 18 66.6
condition n/a
subroutine 13 13 100.0
pod 0 3 0.0
total 134 145 92.4


line stmt bran cond sub pod time code
1             package Excel::Writer::XLSX::Shape;
2              
3             ###############################################################################
4             #
5             # Shape - A class for writing Excel shapes.
6             #
7             # Used in conjunction with Excel::Writer::XLSX.
8             #
9             # Copyright 2000-2019, John McNamara, jmcnamara@cpan.org
10             #
11             # Documentation after __END__
12             #
13              
14             # perltidy with the following options: -mbl=2 -pt=0 -nola
15              
16 1040     1040   17792 use 5.008002;
  1040         3734  
17 1040     1040   5648 use strict;
  1040         2198  
  1040         20616  
18 1040     1040   5041 use warnings;
  1040         2104  
  1040         23229  
19 1040     1040   5322 use Carp;
  1040         2032  
  1040         61034  
20 1040     1040   5865 use Exporter;
  1040         2120  
  1040         620856  
21              
22             our @ISA = qw(Exporter);
23             our $VERSION = '1.03';
24             our $AUTOLOAD;
25              
26             ###############################################################################
27             #
28             # new()
29             #
30             sub new {
31              
32 28     28 0 604 my $class = shift;
33 28         55 my $fh = shift;
34 28         164 my $self = Excel::Writer::XLSX::Package::XMLwriter->new( $fh );
35              
36 28         134 my %properties = @_;
37              
38 28         96 $self->{_name} = undef;
39 28         81 $self->{_type} = 'rect';
40              
41             # Is a Connector shape. 1/0 Value is a hash lookup from type.
42 28         76 $self->{_connect} = 0;
43              
44             # Is a Drawing. Always 0, since a single shape never fills an entire sheet.
45 28         74 $self->{_drawing} = 0;
46              
47             # OneCell or Absolute: options to move and/or size with cells.
48 28         75 $self->{_editAs} = '';
49              
50             # Auto-incremented, unless supplied by user.
51 28         62 $self->{_id} = 0;
52              
53             # Shape text (usually centered on shape geometry).
54 28         81 $self->{_text} = 0;
55              
56             # Shape stencil mode. A copy (child) is created when inserted.
57             # The link to parent is broken.
58 28         66 $self->{_stencil} = 1;
59              
60             # Index to _shapes array when inserted.
61 28         63 $self->{_element} = -1;
62              
63             # Shape ID of starting connection, if any.
64 28         74 $self->{_start} = undef;
65              
66             # Shape vertex, starts at 0, numbered clockwise from 12 o'clock.
67 28         64 $self->{_start_index} = undef;
68              
69 28         71 $self->{_end} = undef;
70 28         99 $self->{_end_index} = undef;
71              
72             # Number and size of adjustments for shapes (usually connectors).
73 28         77 $self->{_adjustments} = [];
74              
75             # Start and end sides. t)op, b)ottom, l)eft, or r)ight.
76 28         112 $self->{_start_side} = '';
77 28         72 $self->{_end_side} = '';
78              
79             # Flip shape Horizontally. eg. arrow left to arrow right.
80 28         68 $self->{_flip_h} = 0;
81              
82             # Flip shape Vertically. eg. up arrow to down arrow.
83 28         71 $self->{_flip_v} = 0;
84              
85             # shape rotation (in degrees 0-360).
86 28         69 $self->{_rotation} = 0;
87              
88             # An alternate way to create a text box, because Excel allows it.
89             # It is just a rectangle with text.
90 28         64 $self->{_txBox} = 0;
91              
92             # Shape outline colour, or 0 for noFill (default black).
93 28         62 $self->{_line} = '000000';
94              
95             # Line type: dash, sysDot, dashDot, lgDash, lgDashDot, lgDashDotDot.
96 28         68 $self->{_line_type} = '';
97              
98             # Line weight (integer).
99 28         60 $self->{_line_weight} = 1;
100              
101             # Shape fill colour, or 0 for noFill (default noFill).
102 28         64 $self->{_fill} = 0;
103              
104             # Formatting for shape text, if any.
105 28         75 $self->{_format} = {};
106              
107             # copy of colour palette table from Workbook.pm.
108 28         86 $self->{_palette} = [];
109              
110             # Vertical alignment: t, ctr, b.
111 28         73 $self->{_valign} = 'ctr';
112              
113             # Alignment: l, ctr, r, just
114 28         65 $self->{_align} = 'ctr';
115              
116 28         86 $self->{_x_offset} = 0;
117 28         84 $self->{_y_offset} = 0;
118              
119             # Scale factors, which also may be set when the shape is inserted.
120 28         109 $self->{_scale_x} = 1;
121 28         67 $self->{_scale_y} = 1;
122              
123             # Default size, which can be modified and/or scaled.
124 28         56 $self->{_width} = 50;
125 28         64 $self->{_height} = 50;
126              
127             # Initial assignment. May be modified when prepared.
128 28         58 $self->{_column_start} = 0;
129 28         65 $self->{_row_start} = 0;
130 28         101 $self->{_x1} = 0;
131 28         60 $self->{_y1} = 0;
132 28         57 $self->{_column_end} = 0;
133 28         64 $self->{_row_end} = 0;
134 28         57 $self->{_x2} = 0;
135 28         60 $self->{_y2} = 0;
136 28         62 $self->{_x_abs} = 0;
137 28         62 $self->{_y_abs} = 0;
138              
139             # Override default properties with passed arguments
140 28         173 while ( my ( $key, $value ) = each( %properties ) ) {
141              
142             # Strip leading "-" from Tk style properties e.g. -color => 'red'.
143 53         105 $key =~ s/^-//;
144              
145             # Add leading underscore "_" to internal hash keys, if not supplied.
146 53 50       145 $key = "_" . $key unless $key =~ m/^_/;
147              
148 53         196 $self->{$key} = $value;
149             }
150              
151 28         77 bless $self, $class;
152 28         105 return $self;
153             }
154              
155              
156             ###############################################################################
157             #
158             # set_properties( name => 'Shape 1', type => 'rect' )
159             #
160             # Set shape properties.
161             #
162             sub set_properties {
163              
164 1     1 0 12 my $self = shift;
165 1         6 my %properties = @_;
166              
167             # Update properties with passed arguments.
168 1         8 while ( my ( $key, $value ) = each( %properties ) ) {
169              
170             # Strip leading "-" from Tk style properties e.g. -color => 'red'.
171 2         5 $key =~ s/^-//;
172              
173             # Add leading underscore "_" to internal hash keys, if not supplied.
174 2 50       8 $key = "_" . $key unless $key =~ m/^_/;
175              
176 2 50       7 if ( !exists $self->{$key} ) {
177 0         0 warn "Unknown shape property: $key. Property not set.\n";
178 0         0 next;
179             }
180              
181 2         12 $self->{$key} = $value;
182             }
183             }
184              
185              
186             ###############################################################################
187             #
188             # set_adjustment( adj1, adj2, adj3, ... )
189             #
190             # Set the shape adjustments array (as a reference).
191             #
192             sub set_adjustments {
193              
194 4     4 0 18 my $self = shift;
195 4         20 $self->{_adjustments} = \@_;
196             }
197              
198              
199             ###############################################################################
200             #
201             # AUTOLOAD. Deus ex machina.
202             #
203             # Dynamically create set/get methods that aren't already defined.
204             #
205             sub AUTOLOAD {
206              
207 127     127   11779 my $self = shift;
208              
209             # Ignore calls to DESTROY.
210 127 100       3354 return if $AUTOLOAD =~ /::DESTROY$/;
211              
212             # Check for a valid method names, i.e. "set_xxx_Cy".
213 54 50       287 $AUTOLOAD =~ /.*::(get|set)(\w+)/ or die "Unknown method: $AUTOLOAD\n";
214              
215             # Match the function (get or set) and attribute, i.e. "_xxx_yyy".
216 54         124 my $gs = $1;
217 54         117 my $attribute = $2;
218              
219             # Check that the attribute exists.
220 54 50       154 exists $self->{$attribute} or die "Unknown method: $AUTOLOAD\n";
221              
222             # The attribute value
223 54         80 my $value;
224              
225             # set_property() pattern.
226             # When a method is AUTOLOADED we store a new anonymous
227             # sub in the appropriate slot in the symbol table. The speeds up subsequent
228             # calls to the same method.
229             #
230 1040     1040   7897 no strict 'refs'; # To allow symbol table hackery
  1040         2300  
  1040         230473  
231              
232 54         92 $value = $_[0];
233 54 100       118 $value = 1 if not defined $value; # The default value is always 1
234              
235 54 100       133 if ( $gs eq 'set' ) {
236 48         190 *{$AUTOLOAD} = sub {
237 17     17   54 my $self = shift;
238 17         31 my $value = shift;
239              
240 17 50       38 $value = 1 if not defined $value;
241 17         35 $self->{$attribute} = $value;
242 48         224 };
243              
244 48         230 $self->{$attribute} = $value;
245             }
246             else {
247 6         37 *{$AUTOLOAD} = sub {
248 20     20   86 my $self = shift;
249 20         82 return $self->{$attribute};
250 6         46 };
251              
252             # Let AUTOLOAD return the attribute for the first invocation
253 6         73 return $self->{$attribute};
254             }
255             }
256              
257              
258             ###############################################################################
259             #
260             # _get_palette_color()
261             #
262             # Convert from an Excel internal colour index to a XML style #RRGGBB index
263             # based on the default or user defined values in the Workbook palette.
264             # Note: This version doesn't add an alpha channel.
265             #
266             sub _get_palette_color {
267              
268 14     14   26 my $self = shift;
269 14         185 my $index = shift;
270 14         33 my $palette = $self->{_palette};
271              
272             # Adjust the colour index.
273 14         67 $index -= 8;
274              
275             # Palette is passed in from the Workbook class.
276 14         24 my @rgb = @{ $palette->[$index] };
  14         37  
277              
278 14         88 return sprintf "%02X%02X%02X", @rgb[0, 1, 2];
279             }
280              
281              
282             1;
283              
284             __END__