File Coverage

blib/lib/Email/Folder/Exchange/WebDAV.pm

Criterion	Covered	Total	%
statement	21	125	16.8
branch	0	28	0.0
condition	0	25	0.0
subroutine	7	20	35.0
pod	6	7	85.7
total	34	205	16.5

package Email::Folder::Exchange::WebDAV;
use strict;

# vim: ft=perl fdm=marker ts=4 sw=4

our $VERSION = '1.10';

use base qw(Email::Folder);
use Email::Folder;
use URI;
use URI::Escape;
use LWP::UserAgent;

use Carp qw(carp croak);

sub _ua { # {{{
    my ($self, $ua) = @_;
    $self->{_ua} = $ua if @_ == 2;
    return $self->{_ua};
} # }}}

sub uri { # {{{
    my ($self, $uri) = @_;
    $self->{uri} = $uri if @_ == 2;
    return $self->{uri};
} # }}}

sub _login { # {{{
    my ($self, $uri, $username, $password) = @_;
    my $scheme = $uri->scheme;
    my $host = $uri->host;
    my $ua = $self->_ua;

    # login using FBA (forms-based authentication)
    my $auth_uri = $uri->clone;
    $auth_uri->path('exchweb/bin/auth/owaauth.dll');
    my $login_req = HTTP::Request->new(
        POST => $auth_uri->as_string,
    );
    $login_req->content_type('application/x-www-form-urlencoded');
    $login_req->content(
        'destination=' . uri_escape($uri->as_string) .
        '&username=' . uri_escape($username) .
        '&password=' . uri_escape($password)
    );

    my $login_res = $ua->request($login_req);
    croak $login_res->message if $login_res->code >= 400 and $login_res->code < 500;

    return 1;
} # }}}

sub new { # {{{
    my ($self, $class, $url, $username, $password) = ({}, @_);
    bless $self, $class;

    croak "URI required" unless $url;

    # create user agent
    my $ua = LWP::UserAgent->new( keep_alive => 1, cookie_jar => {} );
    $self->_ua($ua);

    # create uri object
    my $uri = URI->new($url);
    $self->uri($uri);

		# guess path
		if(! $uri->path || $uri->path =~ m{^/$}) {
		  my $path_user = $username;
			$path_user =~ s/.*\\//;

			$uri->path("/exchange/$path_user/Inbox");
		}


    # get credentials from url if specified
    my $credentials = $uri->userinfo;
    $uri->userinfo(undef);

    if($credentials && !($username || $password)) {
        ($username, $password) = split(/:/, uri_unescape($credentials), 2);
    }
    croak "Credentials required" unless $username;

    $self->_login($uri, $username, $password);

    return $self;
} # }}}

sub _message_urls { # {{{
    my ($self) = @_;
    return $self->{_message_urls} if $self->{_message_urls};

    my $req = HTTP::Request->new(
        SEARCH => $self->uri->as_string,
    );
    $req->content_type('text/xml');
    $req->header(Depth => 1);


    my $folder_path = $self->uri->path;
    $req->content(qq{


        SELECT "DAV:ishidden"
          FROM scope('shallow traversal of "$folder_path"')
         WHERE "DAV:ishidden"=False AND "DAV:isfolder"=False

    });

    my $ua = $self->_ua;

    my @message_urls;
    my $buf = "";

    my $res = $ua->request($req, sub {
        my $chunk = shift;
        $buf .= $chunk;

        while($buf =~ m#(.*?)#g) {
            push @message_urls, $1;

        }
        $buf = substr($buf, (pos $buf || 0));
    });
    croak $res->message unless $res->code >= 200 and $res->code < 300;

    $self->{_message_urls} = \@message_urls;

    return $self->{_message_urls};
} # }}}

sub messages { # {{{
    my $self = shift;

    my @messages;
    while(my $message = $self->next_message) {
        push @messages, $message;
    }

    return @messages;
} # }}}

sub next_message { # {{{
    my $self = shift;
    my $message_url = shift @{ $self->_message_urls };
    return undef unless defined $message_url;

    my $req = HTTP::Request->new( GET => $message_url );
    $req->header(Translate => 'f');
    my $res = $self->_ua->request($req);
    croak $res->message unless $res->code >= 200 and $res->code < 300;

    return $self->bless_message($res->content);
} # }}}

sub _folder_urls { # {{{
    my ($self) = @_;
    return $self->{_folder_urls} if $self->{_folder_urls};

    my $req = HTTP::Request->new(
        SEARCH => $self->uri->as_string,
    );
    $req->content_type('text/xml');
    $req->header(Depth => 1);

    my $folder_path = $self->uri->path;
    $req->content(qq{


        SELECT "DAV:ishidden"
          FROM scope('shallow traversal of "$folder_path"')
         WHERE "DAV:ishidden"=False AND "DAV:isfolder"=True

    });

    my $ua = $self->_ua;

    my @folder_urls;
    my $buf = "";

    my $res = $ua->request($req, sub {
        my $chunk = shift;
        $buf .= $chunk;

        while($buf =~ m#(.*?)#g) {
            push @folder_urls, $1;

        }

        $buf = substr($buf, (pos $buf || 0));
    });
    croak $res->message unless $res->code >= 200 and $res->code < 300;

    $self->{_folder_urls} = \@folder_urls;

    return $self->{_folder_urls};
} # }}}

sub folders { # {{{
    my $self = shift;

    my @folders;
    while(my $folder = $self->next_folder) {
        push @folders, $folder;
    }

    return @folders;
} # }}}

sub next_folder { # {{{
    my $self = shift;

    my $folder_url = shift @{ $self->_folder_urls };
    return unless defined $folder_url;

    my $folder = $self->clone;
    $folder->uri(URI->new($folder_url));

    return $folder;
} # }}}

sub clone { # {{{
    my $self = shift;

    my $clone = bless {
        uri => $self->uri->clone,
        _ua => $self->_ua->clone,
    }, ref $self;

    # copy cookie jar
    $clone->_ua->{cookie_jar} = $self->_ua->{cookie_jar};

    return $clone;
} # }}}

1;
__END__