| File: | lib/WWW/Google/Contacts/Base.pm |
| Coverage: | 17.0% |
| line | stmt | bran | cond | sub | pod | time | code |
|---|---|---|---|---|---|---|---|
| 1 | package WWW::Google::Contacts::Base; | ||||||
| 2 | |||||||
| 3 | 12 12 12 | 82 39 83 | use Moose; | ||||
| 4 | 12 12 12 | 133 37 101 | use Scalar::Util qw( blessed ); | ||||
| 5 | |||||||
| 6 | sub xml_attributes { | ||||||
| 7 | 38 | 0 | 148 | my $self = shift; | |||
| 8 | 38 206 | 275 10490 | return grep { $_->does( 'XmlField' ) } | ||||
| 9 | $self->meta->get_all_attributes; | ||||||
| 10 | } | ||||||
| 11 | |||||||
| 12 | sub get_xml_key { | ||||||
| 13 | 0 | 0 | my ($self, $field) = @_; | ||||
| 14 | |||||||
| 15 | 0 | foreach my $attr ( $self->xml_attributes ) { | |||||
| 16 | 0 | my $name = $attr->name; | |||||
| 17 | 0 | my $val = $self->$name; | |||||
| 18 | 0 | if ( $name eq $field ) { | |||||
| 19 | 0 | return $attr->xml_key; | |||||
| 20 | } | ||||||
| 21 | elsif ( blessed($val) and $val->can("to_xml_hashref") ) { | ||||||
| 22 | 0 | my $recurse = $val->get_xml_key( $field ); | |||||
| 23 | 0 | if ( $recurse ) { | |||||
| 24 | 0 | my $parent = $attr->xml_key; | |||||
| 25 | 0 | return { $parent => $recurse }; | |||||
| 26 | } | ||||||
| 27 | } | ||||||
| 28 | } | ||||||
| 29 | 0 | return undef; | |||||
| 30 | } | ||||||
| 31 | |||||||
| 32 | sub to_xml_hashref { | ||||||
| 33 | 0 | 0 | my $self = shift; | ||||
| 34 | |||||||
| 35 | 0 | my $to_return = {}; | |||||
| 36 | 0 | foreach my $attr ( $self->xml_attributes ) { | |||||
| 37 | 0 | my $incl = $attr->include_in_xml; | |||||
| 38 | 0 | next unless $self->$incl; | |||||
| 39 | |||||||
| 40 | 0 | my $predicate = $attr->predicate; | |||||
| 41 | |||||||
| 42 | 0 | next if defined $predicate | |||||
| 43 | and not $self->$predicate | ||||||
| 44 | and not $attr->is_lazy; | ||||||
| 45 | |||||||
| 46 | 0 | my $name = $attr->name; | |||||
| 47 | 0 | my $val = $self->$name; | |||||
| 48 | |||||||
| 49 | 0 | $to_return->{ $attr->xml_key } = | |||||
| 50 | ( blessed($val) and $val->can("to_xml_hashref") ) ? $val->to_xml_hashref | ||||||
| 51 | 0 | : ( ref($val) and ref($val) eq 'ARRAY' ) ? [ map { $_->to_xml_hashref } @{ $val } ] | |||||
| 52 | 0 0 0 | : $attr->has_to_xml ? do { my $code = $attr->to_xml ; &$code( $val ) } | |||||
| 53 | : $attr->is_element ? [ $val ] | ||||||
| 54 | : $val; | ||||||
| 55 | } | ||||||
| 56 | 0 | return $to_return; | |||||
| 57 | } | ||||||
| 58 | |||||||
| 59 | sub set_from_server { | ||||||
| 60 | 0 | 0 | my ($self, $data) = @_; | ||||
| 61 | |||||||
| 62 | 0 | foreach my $attr ( $self->xml_attributes ) { | |||||
| 63 | 0 | if ( defined $data->{ $attr->xml_key } ) { | |||||
| 64 | 0 | if ( my $writer = $attr->writer ) { | |||||
| 65 | # write attributes that are read only to the user | ||||||
| 66 | 0 | $self->$writer( $data->{ $attr->xml_key } ); | |||||
| 67 | } | ||||||
| 68 | else { | ||||||
| 69 | 0 | my $name = $attr->name; | |||||
| 70 | 0 | $self->$name( $data->{ $attr->xml_key } ); | |||||
| 71 | } | ||||||
| 72 | } | ||||||
| 73 | } | ||||||
| 74 | 0 | return $self; | |||||
| 75 | } | ||||||
| 76 | |||||||
| 77 | around BUILDARGS => sub { | ||||||
| 78 | my $orig = shift; | ||||||
| 79 | my $class = shift; | ||||||
| 80 | |||||||
| 81 | return $class->$orig() unless ( @_ ); | ||||||
| 82 | |||||||
| 83 | # let's see if we need to mangle xml fields | ||||||
| 84 | my $data; | ||||||
| 85 | if ( @_ > 1 ) { | ||||||
| 86 | $data = {@_}; | ||||||
| 87 | } | ||||||
| 88 | else { | ||||||
| 89 | $data = shift @_; | ||||||
| 90 | } | ||||||
| 91 | |||||||
| 92 | foreach my $attr ( $class->xml_attributes ) { | ||||||
| 93 | if ( defined $data->{ $attr->xml_key } ) { | ||||||
| 94 | $data->{ $attr->name } = delete $data->{ $attr->xml_key }; | ||||||
| 95 | } | ||||||
| 96 | } | ||||||
| 97 | return $class->$orig( $data ); | ||||||
| 98 | }; | ||||||
| 99 | |||||||
| 100 | 12 12 12 | 140 38 90 | no Moose; | ||||
| 101 | __PACKAGE__->meta->make_immutable; | ||||||
| 102 | 1; | ||||||