| 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; |