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