File Coverage

blib/lib/SVG/Extension.pm
Criterion Covered Total %
statement 21 138 15.2
branch 0 66 0.0
condition 0 3 0.0
subroutine 7 39 17.9
pod 8 32 25.0
total 36 278 12.9


line stmt bran cond sub pod time code
1             package SVG::Extension;
2 25     25   177 use strict;
  25         46  
  25         762  
3 25     25   126 use warnings;
  25         47  
  25         1133  
4              
5             our $VERSION = '2.85';
6              
7             =head1 NAME
8              
9             SVG::Extension - additional methods
10              
11             =cut
12              
13             # although DTD declarations are not elements, we use the same API so we can
14             # manipulate the internal DTD subset using the same methods available for
15             # elements. At this state, all extensions are the same object class, but
16             # may be subclassed in the future to e.g. SVG::Extension::ELEMENT. Use
17             # e.g. isElementDecl() to determine types; this API will be retained
18             # irrespective.
19              
20 25     25   166 use parent qw/SVG::Element/;
  25         81  
  25         402  
21              
22             # DTD declarations handled in this module
23 25     25   1868 use constant ELEMENT => 'ELEMENT';
  25         75  
  25         2904  
24 25     25   182 use constant ATTLIST => 'ATTLIST';
  25         60  
  25         1363  
25 25     25   162 use constant NOTATION => 'NOTATION';
  25         72  
  25         1306  
26 25     25   154 use constant ENTITY => 'ENTITY';
  25         43  
  25         53214  
27              
28             our @TYPES = ( ELEMENT, ATTLIST, NOTATION, ENTITY );
29             our %TYPES = map { $_ => 1 } @TYPES;
30              
31             #-----------------
32              
33             sub new {
34 0     0 0   return shift->SUPER::new(@_);
35             }
36              
37             sub internal_subset {
38 0     0 0   my $self = shift;
39              
40 0           my $document = $self->{-docref};
41 0 0         unless ( exists $document->{-internal} ) {
42 0           $document->{-internal} = new SVG::Extension('internal');
43 0           $document->{-internal}{-docref} = $document;
44             }
45              
46 0           return $document->{-internal};
47             }
48              
49             =head2 extension
50              
51             return the element object
52              
53             =cut
54              
55             sub extension {
56 0     0 1   my $self = shift;
57 0   0       my $class = ref($self) || $self;
58              
59 0           return bless $self->SUPER::element(@_), $class;
60             }
61              
62             #-----------------
63              
64             =head2 element_decl
65              
66             generate an element declaration in the DTD
67              
68             =cut
69              
70             sub element_decl {
71 0     0 1   my ( $self, %attrs ) = @_;
72 0           my $subset = $self->internal_subset();
73              
74 0           return $subset->extension( 'ELEMENT', %attrs );
75             }
76              
77             =head2 attribute_decl
78              
79             return generate an attribute list for an element
80              
81             =cut
82              
83             sub attribute_decl {
84 0     0 1   my ( $element_decl, %attrs ) = @_;
85              
86 0 0         unless ( $element_decl->getElementType eq 'ELEMENT' ) {
87 0           $element_decl->error(
88             $element_decl => 'is not an ELEMENT declaration' );
89 0           return;
90             }
91              
92 0           return $element_decl->extension( 'ATTLIST', %attrs );
93             }
94              
95             =head2 attlist_decl
96              
97             =cut
98              
99             sub attlist_decl {
100 0     0 1   my ( $self, %attrs ) = @_;
101 0           my $subset = $self->internal_subset();
102              
103 0           my $element_decl = $subset->getElementDeclByName( $attrs{name} );
104 0 0         unless ($element_decl) {
105 0           $subset->error( "ATTLIST declaration '$attrs{attr}'" =>
106             "ELEMENT declaration '$attrs{name}' does not exist" );
107 0           return;
108             }
109              
110 0           return $element_decl->attribute_decl(%attrs);
111             }
112              
113             =head2 notation_decl(%attrs)
114              
115             return an extension object of type NOTATION
116              
117             =cut
118              
119             sub notation_decl {
120 0     0 1   my ( $self, %attrs ) = @_;
121 0           my $subset = $self->internal_subset();
122              
123 0           return $subset->extension( 'NOTATION', %attrs );
124             }
125              
126             =head2 entity_decl(%attrs)
127              
128             return an extension object of type 'ENTITY'
129              
130             =cut
131              
132             sub entity_decl {
133 0     0 1   my ( $self, %attrs ) = @_;
134 0           my $subset = $self->internal_subset();
135              
136 0           return $subset->extension( 'ENTITY', %attrs );
137             }
138              
139             #-----------------
140              
141             # this interim version of xmlify handles the vanilla extension
142             # format of one parent 'internal' element containing a list of
143             # extension elements. A hierarchical model will follow in time
144             # with the same render API.
145              
146             =head2 xmilfy
147              
148             =cut
149              
150             sub xmlify {
151 0     0 0   my $self = shift;
152 0           my $decl = q{};
153              
154 0 0         if ( $self->{-name} ne 'internal' ) {
155 0           $decl = '
156 0           SWITCH: foreach ( $self->{-name} ) {
157 0 0         /^ELEMENT$/ and do {
158 0           $decl .= "ELEMENT $self->{name}";
159              
160 0 0         $decl .= q{ } . $self->{model} if exists $self->{model};
161              
162 0           last SWITCH;
163             };
164 0 0         /^ATTLIST$/ and do {
165 0           $decl .= "ATTLIST $self->{name} $self->{attr}";
166              
167             $decl
168             .= " $self->{type} "
169             . ( $self->{fixed} ? '#FIXED ' : q{} )
170 0 0         . $self->{default};
171              
172 0           last SWITCH;
173             };
174 0 0         /^NOTATION$/ and do {
175 0           $decl .= "NOTATION $self->{name}";
176              
177 0 0         $decl .= q{ } . $self->{base} if exists $self->{base};
178 0 0         if ( exists $self->{pubid} ) {
    0          
179 0           $decl .= "PUBLIC $self->{pubid} ";
180 0 0         $decl .= q{ } . $self->{sysid} if exists $self->{sysid};
181             }
182             elsif ( exists $self->{sysid} ) {
183             $decl .= ' SYSTEM ' . $self->{sysid}
184 0 0         if exists $self->{sysid};
185             }
186              
187 0           last SWITCH;
188             };
189 0 0         /^ENTITY$/ and do {
190             $decl
191             .= 'ENTITY '
192             . ( $self->{isp} ? '% ' : q{} )
193 0 0         . $self->{name};
194              
195 0 0         if ( exists $self->{value} ) {
    0          
196 0           $decl .= ' "' . $self->{value} . '"';
197             }
198             elsif ( exists $self->{pubid} ) {
199 0           $decl .= "PUBLIC $self->{pubid} ";
200 0 0         $decl .= q{ } . $self->{sysid} if exists $self->{sysid};
201 0 0         $decl .= q{ } . $self->{ndata} if $self->{ndata};
202             }
203             else {
204             $decl .= ' SYSTEM ' . $self->{sysid}
205 0 0         if exists $self->{sysid};
206 0 0         $decl .= q{ } . $self->{ndata} if $self->{ndata};
207             }
208              
209 0           last SWITCH;
210 0           DEFAULT:
211              
212             # we don't know what this is, but the underlying parser allowed it
213             $decl .= "$self->{-name} $self->{name}";
214             };
215             }
216 0           $decl .= '>' . $self->{-docref}{-elsep};
217             }
218              
219 0           my $result = q{};
220 0 0         if ( $self->hasChildren ) {
221 0           $self->{-docref}->{-level}++;
222 0           foreach my $child ( $self->getChildren ) {
223             $result
224             .= ( $self->{-docref}{-indent} x $self->{-docref}->{-level} )
225 0           . $child->render();
226             }
227 0           $self->{-docref}->{-level}--;
228             }
229              
230 0           return $decl . $result;
231             }
232              
233             #some aliases for xmilfy
234              
235             =head2 render
236              
237             alias for xmlify
238              
239             =head2 to_xml
240              
241             alias for xmlify
242              
243             =head2 serialise
244              
245             alias for xmlify
246              
247             =head2 serialise
248              
249             alias for xmlify
250              
251             =cut
252              
253             *render = \&xmlify;
254             *to_xml = \&xmlify;
255             *serialise = \&xmlify;
256             *serialize = \&xmlify;
257              
258             #-----------------
259              
260             =head2 getDeclName
261              
262             Simply an alias for the general method for SVG::Extension objects
263              
264             =head2 getExtensionName
265              
266             alias to getDeclName
267              
268             =cut
269              
270             # simply an alias for the general method for SVG::Extension objects
271             sub getDeclName {
272 0     0 1   return shift->SUPER::getElementName();
273             }
274             *getExtensionName = \&getDeclName;
275              
276             =head2 getDeclNames
277              
278             return list of existing decl types by extracting it from the overall list
279             of existing element types
280              
281             sub getDeclNames {
282              
283             =head2 getExtensionNames
284              
285             alias to getDeclNames
286              
287             =cut
288              
289             # return list of existing decl types by extracting it from the overall list
290             # of existing element types
291             sub getDeclNames {
292 0     0 1   my $self = shift;
293              
294 0           return grep { exists $TYPES{$_} } $self->SUPER::getElementNames();
  0            
295             }
296             *getExtensionNames = \&getDeclNames;
297              
298             #-----------------
299              
300             # we can have only one element decl of a given name...
301             sub getElementDeclByName {
302 0     0 0   my ( $self, $name ) = @_;
303 0           my $subset = $self->internal_subset();
304              
305 0           my @element_decls = $subset->getElementsByName('ELEMENT');
306 0           foreach my $element_decl (@element_decls) {
307 0 0         return $element_decl if $element_decl->{name} eq $name;
308             }
309              
310 0           return;
311             }
312              
313             # ...but we can have multiple attributes. Note that this searches the master list
314             # which is not what you are likely to want in most cases. See getAttributeDeclByName
315             # (no 's') below, to search for an attribute decl on a particular element decl.
316             # You can use the result of this method along with getParent to find the list of
317             # all element decls that define a given attribute.
318             sub getAttributeDeclsByName {
319 0     0 0   my ( $self, $name ) = @_;
320 0           my $subset = $self->internal_subset();
321              
322 0           my @element_decls = $subset->getElementsByName('ELEMENT');
323 0           foreach my $element_decl (@element_decls) {
324 0 0         return $element_decl if $element_decl->{name} eq $name;
325             }
326              
327 0           return;
328             }
329              
330             #-----------------
331              
332             sub getElementDecls {
333 0     0 0   return shift->SUPER::getElements('ELEMENT');
334             }
335              
336             sub getNotations {
337 0     0 0   return shift->SUPER::getElements('NOTATION');
338             }
339             *getNotationDecls = \&getNotations;
340              
341             sub getEntities {
342 0     0 0   return shift->SUPER::getElements('ENTITY');
343             }
344             *getEntityDecls = \&getEntities;
345              
346             sub getAttributeDecls {
347 0     0 0   return shift->SUPER::getElements('ATTLIST');
348             }
349              
350             #-----------------
351             # until/unless we subclass these, use the name. After (if) we
352             # subclass, will use the object class.
353              
354             sub isElementDecl {
355 0 0   0 0   return ( shift->getElementName eq ELEMENT ) ? 1 : 0;
356             }
357              
358             sub isNotation {
359 0 0   0 0   return ( shift->getElementName eq NOTATION ) ? 1 : 0;
360             }
361              
362             sub isEntity {
363 0 0   0 0   return ( shift->getElementName eq ENTITY ) ? 1 : 0;
364             }
365              
366             sub isAttributeDecl {
367 0 0   0 0   return ( shift->getElementName eq ATTLIST ) ? 1 : 0;
368             }
369              
370             #-----------------
371              
372             # the Decl 'name' is an attribute, the name is e.g. 'ELEMENT'
373             # use getElementName if you want the actual decl type
374             sub getElementDeclName {
375 0     0 0   my $self = shift;
376              
377 0 0         if ( exists $self->{name} ) {
378 0           return $self->{name};
379             }
380              
381 0           return;
382             }
383              
384             # identical to the above; will be smarter as and when we subclass
385             # as above, the name is ATTLIST, the 'name' is a property of the decl
386             sub getAttributeDeclName {
387 0     0 0   my $self = shift;
388              
389 0 0         if ( exists $self->{name} ) {
390 0           return $self->{name};
391             }
392              
393 0           return;
394             }
395              
396             # unlike other 'By' methods, attribute searches work from their parent element
397             # del only. Multiple element decls with the same attribute name is more than
398             # likely, so searching the master ATTLIST is not very useful. If you really want
399             # to do that, use getAttributeDeclsByName (with an 's') above.
400             sub getAttributeDeclByName {
401 0     0 0   my ( $self, $name ) = @_;
402              
403 0           my @attribute_decls = $self->getElementAttributeDecls();
404 0           foreach my $attribute_decl (@attribute_decls) {
405 0 0         return $attribute_decl if $attribute_decl->{name} eq $name;
406             }
407              
408 0           return;
409             }
410              
411             # as this is element specific, we allow a 'ElementAttribute' name too,
412             # for those that like consistency at the price of brevity. Not that
413             # the shorter name is all that brief to start with...
414             *getElementAttributeDeclByName = \&getAttributeDeclByName;
415              
416             # ...and for those who live their brevity:
417             *getAttributeDecl = \&getAttributeDeclByName;
418              
419             sub hasAttributeDecl {
420 0 0   0 0   return ( shift->getElementDeclByName(shift) ) ? 1 : 0;
421             }
422              
423             #-----------------
424             # directly map to Child/Siblings: we presume this is being called from an
425             # element decl. You can use 'getChildIndex', 'getChildAtIndex' etc. as well
426              
427             sub getElementAttributeAtIndex {
428 0     0 0   my ( $self, $index, @children ) = @_;
429              
430 0           return $self->SUPER::getChildAtIndex( $index, @children );
431             }
432              
433             sub getElementAttributeIndex {
434 0     0 0   return shift->SUPER::getChildIndex(@_);
435             }
436              
437             sub getFirstAttributeDecl {
438 0     0 0   return shift->SUPER::getFirstChild();
439             }
440              
441             sub getNextAttributeDecl {
442 0     0 0   return shift->SUPER::getNextSibling();
443             }
444              
445             sub getLastAttributeDecl {
446 0     0 0   return shift->SUPER::getLastChild();
447             }
448              
449             sub getPreviousAttributeDecl {
450 0     0 0   return shift->SUPER::getPreviousSibling();
451             }
452              
453             sub getElementAttributeDecls {
454 0     0 0   return shift->SUPER::getChildren();
455             }
456              
457             #-------------------------------------------------------------------------------
458              
459             # These methods are slated for inclusion in a future release of SVG.pm. They
460             # will allow programmatic advance determination of the validity of various DOM
461             # manipulations. If you are in a hurry for this feature, get in touch!
462             #
463             # example:
464             # if ($svg_object->allowsElement("symbol")) { ... }
465             #
466             #package SVG::Element;
467             #
468             #sub allowedElements {}
469             #sub allowedAttributes {}
470             #
471             #sub allowsElement {}
472             #sub allowsAttribute {}
473             #
474              
475             #-------------------------------------------------------------------------------
476              
477             1;