view release on metacpan or  search on metacpan

lib/AnyEvent/WebService/Tracks.pm  view on Meta::CPAN

use XML::Parser;
use XML::Writer;

use AnyEvent::WebService::Tracks::Context;
use AnyEvent::WebService::Tracks::Project;
use AnyEvent::WebService::Tracks::Todo;

our $VERSION = '0.02';

sub new {
    my ( $class, %params ) = @_;

    return bless {
        url      => URI->new($params{url}),
        username => $params{username},
        password => $params{password},
    }, $class;
}

sub parse_datetime {
    my ( $self, $str ) = @_;

    return DateTime::Format::ISO8601->parse_datetime($str);
}

sub format_datetime {
    my ( $self, $datetime ) = @_;

    my @fields = qw/year month day hour minute second/;
    my %attrs = map { $_ => $datetime->$_() } @fields;
    my $offset = DateTime::TimeZone->offset_as_string($datetime->offset);

    return sprintf '%04d-%02d-%02dT%02d:%02d:%02d%s', @attrs{@fields}, $offset;
}

sub handle_error {
    my ( $self, $body, $headers, $cb ) = @_;

    my $message;

    if($body) {
        # context creation serves errors in XML, but project creation in plain text,
        # even though the Content-Type is application/xml...
        if($body =~ /^\s*<\?xml/) {
            my $error = $self->parse_single(undef, $body);
            $message  = $error->{'error'};
        } else {
            $message = $body;
        }
    } else {
        $message = $headers->{'status'};
    }

    $cb->(undef, $message);
}

sub generate_xml {
    my ( $self, $root, $attrs ) = @_;

    my $xml  = '';
    my $w    = XML::Writer->new(OUTPUT => \$xml);
    my @keys = sort keys %$attrs;

    $w->startTag($root);
    foreach my $k (@keys) {
        my $v = $attrs->{$k};
        my @xml_attrs;

        push @xml_attrs, (nil => 'true') unless defined $v;
        if(ref($v) eq 'DateTime') {
            push @xml_attrs, (type => 'datetime');
            $v = $self->format_datetime($v);
        }

        my $nk = $k;
        $nk =~ tr/_/-/;

        $w->startTag($nk, @xml_attrs);
        $w->characters($v) if defined $v;
        $w->endTag($nk);
    }
    $w->endTag($root);
    $w->end;

    return $xml;
}

sub status_successful {
    my ( $self, $status ) = @_;

    return ($status >= 200 && $status < 300);
}

sub do_request {
    my ( $self, $http_method, $uri, $params, $method, $cb ) = @_;

    my ( $username, $password ) = @{$self}{qw/username password/};

    my $auth_token = encode_base64(join(':', $username, $password), '');
    $params->{'headers'} = {
        Authorization => "Basic $auth_token",
        Accept        => 'application/xml',
        Referer       => undef,
    };
    if($params->{'body'}) {
        $params->{'headers'}{'Content-Type'} = 'text/xml';
    }

    my $handle_result = sub {
        my ( $data, $headers ) = @_;

        if($self->status_successful($headers->{'Status'})) {
            $cb->($self->$method($data, $headers));
        } else {
            $self->handle_error($data, $headers, $cb);
        }
    };

    unless(ref($uri) eq 'URI') {
        if(ref($uri) eq 'ARRAY') {
            my $copy = $self->{url}->clone;
            $copy->path_segments($copy->path_segments, @$uri);
            $uri = $copy;
        }
    }

    http_request $http_method, $uri, %$params, $handle_result;
}

sub do_get {
    my ( $self, $uri, $method, $cb ) = @_;

    $self->do_request(GET => $uri, {}, $method, $cb);
}

sub do_delete {
    my ( $self, $uri, $method, $cb ) = @_;

    $self->do_request(DELETE => $uri, {}, $method, $cb);
}

sub do_post {
    my ( $self, $uri, $body, $method, $cb ) = @_;

    $self->do_request(POST => $uri, { body => $body }, $method, $cb);
}

sub do_put {
    my ( $self, $uri, $body, $method, $cb ) = @_;

    $self->do_request(PUT => $uri, { body => $body }, $method, $cb);
}

sub parse_entities {
    my ( $self, $xml, $type, $target_depth ) = @_;

    my @entities;
    my $current_entity;
    my $current_tag;
    my $current_attrs;
    my $depth = 0;

    my $parser = XML::Parser->new(
        Handlers => {
            Start => sub {
                my ( undef, $tag, %attrs ) = @_;

                if($depth == $target_depth) {
                    $current_entity = {};
                } elsif($depth > $target_depth) {
                    $current_tag = $tag;
                    $current_attrs = \%attrs;

                    $current_tag =~ tr/-/_/;

                    my $nil = $attrs{'nil'};
                    $nil = defined($nil) && $nil eq 'true';
                    
                    if($nil) {
                        $current_entity->{$current_tag} = undef;
                    } else {
                        $current_entity->{$current_tag} = '';
                    }
                }

                $depth++;
            },
            End   => sub {
                my ( undef, $tag ) = @_;

                $depth--;

                if($depth == $target_depth) {
                    if(defined $type) {
                        push @entities, $type->new(parent => $self,
                            %$current_entity);
                    } else {
                        push @entities, $current_entity;
                    }

                    undef $current_entity;
                    undef $current_tag;
                    undef $current_attrs;
                } elsif($depth > $target_depth) {
                    my $type = $current_attrs->{'type'};
                    $type = '' unless defined $type;

                    if($type eq 'datetime') {
                        my $value = $current_entity->{$current_tag};

                        if(defined $value) {