local-lib5/lib/perl5/XML/Atom/Base.pm

   1 # $Id$
   2
   3 package XML::Atom::Base;
   4 use strict;
   5 use base qw( XML::Atom::ErrorHandler Class::Data::Inheritable );
   6
   7 use Encode;
   8 use XML::Atom;
   9 use XML::Atom::Util qw( set_ns first nodelist childlist create_element );
  10
  11 __PACKAGE__->mk_classdata('__attributes', []);
  12
  13 sub new {
  14     my $class = shift;
  15     my $obj = bless {}, $class;
  16     $obj->init(@_) or return $class->error($obj->errstr);
  17     $obj;
  18 }
  19
  20 sub init {
  21     my $obj = shift;
  22     my %param = @_;
  23     if (!exists $param{Namespace} and my $ns = $obj->element_ns) {
  24         $param{Namespace} = $ns;
  25     }
  26     $obj->set_ns(\%param);
  27     my $elem;
  28     unless ($elem = $param{Elem}) {
  29         if (LIBXML) {
  30             my $doc = XML::LibXML::Document->createDocument('1.0', 'utf-8');
  31             my $ns = $obj->ns;
  32             my ($ns_uri, $ns_prefix);
  33             if ( ref $ns and $ns->isa('XML::Atom::Namespace') ) {
  34                 $ns_uri     = $ns->{uri};
  35                 $ns_prefix  = $ns->{prefix};
  36             } else {
  37                 $ns_uri = $ns;
  38             }
  39             if ( $ns_uri and $ns_prefix ) {
  40                 $elem = $doc->createElement($obj->element_name);
  41                 $elem->setNamespace( $ns_uri, $ns_prefix, 1 );
  42             } else {
  43                 $elem = $doc->createElementNS($obj->ns, $obj->element_name);
  44             }
  45             $doc->setDocumentElement($elem);
  46         } else {
  47             $elem = XML::XPath::Node::Element->new($obj->element_name);
  48             my $ns = XML::XPath::Node::Namespace->new('#default' => $obj->ns);
  49             $elem->appendNamespace($ns);
  50         }
  51     }
  52     $obj->{elem} = $elem;
  53     $obj;
  54 }
  55
  56 sub element_name { }
  57 sub element_ns { }
  58
  59 sub ns   { $_[0]->{ns} }
  60 sub elem { $_[0]->{elem} }
  61
  62 sub version {
  63     my $atom = shift;
  64     XML::Atom::Util::ns_to_version($atom->ns);
  65 }
  66
  67 sub content_type {
  68     my $atom = shift;
  69     if ($atom->version >= 1.0) {
  70         return "application/atom+xml";
  71     } else {
  72         return "application/x.atom+xml";
  73     }
  74 }
  75
  76 sub get {
  77     my $obj = shift;
  78     my($ns, $name) = @_;
  79     my @list = $obj->getlist($ns, $name);
  80     return $list[0];
  81 }
  82
  83 sub getlist {
  84     my $obj = shift;
  85     my($ns, $name) = @_;
  86     my $ns_uri = ref($ns) eq 'XML::Atom::Namespace' ? $ns->{uri} : $ns;
  87     my @node = nodelist($obj->elem, $ns_uri, $name);
  88     return map {
  89         my $val = LIBXML ? $_->textContent : $_->string_value;
  90         if ($] >= 5.008) {
  91             require Encode;
  92             Encode::_utf8_off($val) unless $XML::Atom::ForceUnicode;
  93         }
  94         $val;
  95      } @node;
  96 }
  97
  98 sub add {
  99     my $obj = shift;
 100     my($ns, $name, $val, $attr) = @_;
 101     return $obj->set($ns, $name, $val, $attr, 1);
 102 }
 103
 104 sub set {
 105     my $obj = shift;
 106     my($ns, $name, $val, $attr, $add) = @_;
 107     my $ns_uri = ref $ns eq 'XML::Atom::Namespace' ? $ns->{uri} : $ns;
 108     my @elem = childlist($obj->elem, $ns_uri, $name);
 109     if (!$add && @elem) {
 110         $obj->elem->removeChild($_) for @elem;
 111     }
 112     my $elem = create_element($ns, $name);
 113     if (UNIVERSAL::isa($val, 'XML::Atom::Base')) {
 114         if (LIBXML) {
 115             for my $child ($val->elem->childNodes) {
 116                 $elem->appendChild($child->cloneNode(1));
 117             }
 118             for my $attr ($val->elem->attributes) {
 119                 next unless ref($attr) eq 'XML::LibXML::Attr';
 120                 $elem->setAttribute($attr->getName, $attr->getValue);
 121             }
 122         } else {
 123             for my $child ($val->elem->getChildNodes) {
 124                 $elem->appendChild($child);
 125             }
 126             for my $attr ($val->elem->getAttributes) {
 127                 $elem->appendAttribute($attr);
 128             }
 129         }
 130     } else {
 131         if (LIBXML) {
 132             $elem->appendChild(XML::LibXML::Text->new($val));
 133         } else {
 134             $elem->appendChild(XML::XPath::Node::Text->new($val));
 135         }
 136     }
 137     $obj->elem->appendChild($elem);
 138     if ($attr) {
 139         while (my($k, $v) = each %$attr) {
 140             $elem->setAttribute($k, $v);
 141         }
 142     }
 143     return $val;
 144 }
 145
 146 sub get_attr {
 147     my $obj = shift;
 148     my($attr) = @_;
 149     my $val = $obj->elem->getAttribute($attr);
 150     if ($] >= 5.008) {
 151         require Encode;
 152         Encode::_utf8_off($val) unless $XML::Atom::ForceUnicode;
 153     }
 154     $val;
 155 }
 156
 157 sub set_attr {
 158     my $obj = shift;
 159     if (@_ == 2) {
 160         my($attr, $val) = @_;
 161         $obj->elem->setAttribute($attr => $val);
 162     } elsif (@_ == 3) {
 163         my($ns, $attr, $val) = @_;
 164         my $attribute = "$ns->{prefix}:$attr";
 165         if (LIBXML) {
 166             $obj->elem->setAttributeNS($ns->{uri}, $attribute, $val);
 167         } else {
 168             my $ns = XML::XPath::Node::Namespace->new(
 169                     $ns->{prefix} => $ns->{uri}
 170                 );
 171             $obj->elem->appendNamespace($ns);
 172             $obj->elem->setAttribute($attribute => $val);
 173         }
 174     }
 175 }
 176
 177 sub get_object {
 178     my $obj = shift;
 179     my($ns, $name, $class) = @_;
 180     my $ns_uri = ref($ns) eq 'XML::Atom::Namespace' ? $ns->{uri} : $ns;
 181     my @elem = childlist($obj->elem, $ns_uri, $name) or return;
 182     my @obj = map { $class->new( Elem => $_, Namespace => $ns ) } @elem;
 183     return wantarray ? @obj : $obj[0];
 184 }
 185
 186 sub mk_elem_accessors {
 187     my $class = shift;
 188     my (@list) = @_;
 189     my $override_ns;
 190
 191     if ( ref $list[-1] ) {
 192         my $ns_list = pop @list;
 193         if ( ref $ns_list eq 'ARRAY' ) {
 194             $ns_list = $ns_list->[0];
 195         }
 196         if ( ref($ns_list) =~ /Namespace/ ) {
 197             $override_ns = $ns_list;
 198         } else {
 199             if ( ref $ns_list eq 'HASH' ) {
 200                 $override_ns = XML::Atom::Namespace->new(%$ns_list);
 201             }
 202             elsif ( not ref $ns_list and $ns_list ) {
 203                 $override_ns = $ns_list;
 204             }
 205         }
 206     }
 207
 208     no strict 'refs';
 209     for my $elem ( @list ) {
 210         (my $meth = $elem) =~ tr/\-/_/;
 211         *{"${class}::$meth"} = sub {
 212             my $obj = shift;
 213             if (@_) {
 214                 return $obj->set( $override_ns || $obj->ns, $elem, $_[0]);
 215             } else {
 216                 return $obj->get( $override_ns || $obj->ns, $elem);
 217             }
 218         };
 219     }
 220 }
 221
 222 sub mk_attr_accessors {
 223     my $class = shift;
 224     my(@list) = @_;
 225     no strict 'refs';
 226     for my $attr (@list) {
 227         (my $meth = $attr) =~ tr/\-/_/;
 228         *{"${class}::$meth"} = sub {
 229             my $obj = shift;
 230             if (@_) {
 231                 return $obj->set_attr($attr => $_[0]);
 232             } else {
 233                 return $obj->get_attr($attr);
 234             }
 235         };
 236         $class->_add_attribute($attr);
 237     }
 238 }
 239
 240 sub _add_attribute {
 241     my($class, $attr) = @_;
 242     push @{$class->__attributes}, $attr;
 243 }
 244
 245 sub attributes {
 246     my $class = shift;
 247     @{ $class->__attributes };
 248 }
 249
 250 sub mk_xml_attr_accessors {
 251     my($class, @list) = @_;
 252     no strict 'refs';
 253     for my $attr (@list) {
 254         (my $meth = $attr) =~ tr/\-/_/;
 255         *{"${class}::$meth"} = sub {
 256             my $obj = shift;
 257             if (LIBXML) {
 258                 my $elem = $obj->elem;
 259                 if (@_) {
 260                     $elem->setAttributeNS('http://www.w3.org/XML/1998/namespace',
 261                                           $attr, $_[0]);
 262                 }
 263                 return $elem->getAttribute("xml:$attr");
 264             } else {
 265                 if (@_) {
 266                     $obj->elem->setAttribute("xml:$attr", $_[0]);
 267                 }
 268                 return $obj->elem->getAttribute("xml:$attr");
 269             }
 270         };
 271     }
 272 }
 273
 274 sub mk_object_accessor {
 275     my $class = shift;
 276     my($name, $ext_class) = @_;
 277     no strict 'refs';
 278     (my $meth = $name) =~ tr/\-/_/;
 279     *{"${class}::$meth"} = sub {
 280         my $obj = shift;
 281         my $ns_uri = $ext_class->element_ns || $obj->ns;
 282         if (@_) {
 283             return $obj->set($ns_uri, $name, $_[0]);
 284         } else {
 285             return $obj->get_object($ns_uri, $name, $ext_class);
 286         }
 287     };
 288 }
 289
 290
 291 sub mk_object_list_accessor {
 292     my $class = shift;
 293     my($name, $ext_class, $moniker) = @_;
 294
 295     no strict 'refs';
 296
 297     *{"$class\::$name"} = sub {
 298         my $obj = shift;
 299
 300         my $ns_uri = $ext_class->element_ns || $obj->ns;
 301         if (@_) {
 302             # setter: clear existent elements first
 303             my @elem = childlist($obj->elem, $ns_uri, $name);
 304             for my $el (@elem) {
 305                 $obj->elem->removeChild($el);
 306             }
 307
 308             # add the new elements for each
 309             my $adder = "add_$name";
 310             for my $add_elem (@_) {
 311                 $obj->$adder($add_elem);
 312             }
 313         } else {
 314             # getter: just call get_object which is a context aware
 315             return $obj->get_object($ns_uri, $name, $ext_class);
 316         }
 317     };
 318
 319     # moniker returns always list: array ref in a scalar context
 320     if ($moniker) {
 321         *{"$class\::$moniker"} = sub {
 322             my $obj = shift;
 323             if (@_) {
 324                 return $obj->$name(@_);
 325             } else {
 326                 my @obj = $obj->$name;
 327                 return wantarray ? @obj : \@obj;
 328             }
 329         };
 330     }
 331
 332     # add_$name
 333     *{"$class\::add_$name"} = sub {
 334         my $obj = shift;
 335         my($stuff) = @_;
 336
 337         my $ns_uri = $ext_class->element_ns || $obj->ns;
 338         my $elem = (ref $stuff && UNIVERSAL::isa($stuff, $ext_class)) ?
 339             $stuff->elem : create_element($ns_uri, $name);
 340         $obj->elem->appendChild($elem);
 341
 342         if (ref($stuff) eq 'HASH') {
 343             for my $k ( $ext_class->attributes ) {
 344                 defined $stuff->{$k} or next;
 345                 $elem->setAttribute($k, $stuff->{$k});
 346             }
 347         }
 348     };
 349 }
 350
 351 sub as_xml {
 352     my $obj = shift;
 353     if (LIBXML) {
 354         my $doc = XML::LibXML::Document->new('1.0', 'utf-8');
 355         $doc->setDocumentElement($obj->elem->cloneNode(1));
 356         return $doc->toString(1);
 357     } else {
 358         return '<?xml version="1.0" encoding="utf-8"?>' . "\n" .
 359             $obj->elem->toString;
 360     }
 361 }
 362
 363 sub as_xml_utf8 {
 364     my $obj = shift;
 365     my $xml = $obj->as_xml;
 366     if (utf8::is_utf8($xml)) {
 367         return Encode::encode_utf8($xml);
 368     }
 369     return $xml;
 370 }
 371
 372 1;