WWW::Shorten::PunyURL - An interface to SAPO's URL shortening service

    use WWW::Shorten::PunyURL;

    my $punyurl = WWW::Shorten::PunyURL->new( url => $long );
    $punyurl->shorten;

    # or

    my $punyurl = WWW::Shorten::PunyURL->new( url => $short );
    $punyurl->long;

    my $punyurl = WWW::Shorten::PunyURL->new(
        url     => $long,
        timeout => 5
    );

    my $punyurl = WWW::Shorten::PunyURL->new( $url );

    my $result = $punyurl->shorten;

    if ( $result ) {
        print $punyurl->url, "is now:\n";
        print "\t", $punyurl->puny, "\n";
        print "\t", $punyurl->ascii, "\n";
        print "\t", $punyurl->preview, "\n";
    } else {
        print STDERR "Error:\n";
        print STDERR $punyurl->errstr, "(", $punyurl->error, "\n";
    }

    $punyurl->long;

    perldoc WWW::Shorten::PunyURL

package WWW::Shorten::PunyURL;

use 5.006;

our $VERSION = '0.03';

use Mouse;

extends 'WWW::Shorten::generic';
extends 'Exporter';

our @EXPORT = qw( makeashorterlink makealongerlink );

use Mouse::Util::TypeConstraints;

use Carp;

use Regexp::Common qw/ URI /;

use URI::Escape qw/ uri_escape_utf8 /;
use LWP::UserAgent;

use XML::LibXML;
use XML::LibXML::XPathContext;

subtype 'URL'
    => as 'Str'
    => where { /$RE{URI}/ };

has 'url'      => (
    is         => 'ro',
    isa        => 'URL',
    required   => 1,
);

has 'puny'     => (
    is         => 'rw',
    isa        => 'Str',
    default    => '',
);

has 'ascii'    => (
    is         => 'rw',
    isa        => 'URL',
);

has 'preview'  => (
    is         => 'rw',
    isa        => 'URL',
);

has 'original' => (
    is         => 'rw',
    isa        => 'Str',
    default    => '',
);

has 'browser'  => (
    is         => 'rw',
    isa        => 'LWP::UserAgent',
    lazy_build => 1
);

has 'timeout'  => (
    is         => 'rw',
    isa        => 'Int',
    default    => 10,
);

has 'error'    => (
    is         => 'rw',
    isa        => 'Str',
    default    => '',
);

has 'errstr'   => (
    is         => 'rw',
    isa        => 'Str',
    default    => '',
);

has 'parser'   => (
    is         => 'rw',
    isa        => 'XML::LibXML',
    lazy_build => 1,
);

no Mouse;
no Mouse::Util::TypeConstraints;
__PACKAGE__->meta->make_immutable;

use constant ENDPOINT => 'http://services.sapo.pt/PunyURL';

sub makeashorterlink {
    my $url  = shift or croak 'No URL passed to makeashorterlink()';
    
    my $puny = __PACKAGE__->new( $url );
    
    return $puny->shorten->ascii;
}

sub makealongerlink {
    my $puny = shift or croak 'No PunyURL passed to makealongerlink()';
    
    my $url = __PACKAGE__->new( $puny );
    
    return $url->long->original;
}

sub shorten {
    my $self = shift;
    
    my $request = ENDPOINT.'/GetCompressedURLByURL?url='.$self->_urlencode;
    
    my $xml = $self->_do_http( $request );
    return undef unless $xml;
    
    my $xpc     = $self->_get_xpc( $xml );
    my $puny    = $xpc->findvalue( '//p:puny' );
    my $ascii   = $xpc->findvalue( '//p:ascii' );
    my $preview = $xpc->findvalue( '//p:preview' );
    
    $self->puny( $puny );
    $self->ascii( $ascii );
    $self->preview( $preview );
    
    return $self;
}

sub long {
    my $self = shift;
    
    my $request = ENDPOINT.'/GetURLByCompressedURL?url='.$self->_urlencode;

    my $xml = $self->_do_http( $request );
    return undef unless $xml;
    
    my $xpc      = $self->_get_xpc( $xml );    
    my $original = $xpc->findvalue( '//p:url' );

    $self->original( $original );
    
    return $self;
}

sub _do_http {
    my $self = shift;
    my $uri  = shift;
    
    my $response = $self->browser->get( $uri );
    
    if ( ! $response->is_success ) {
        $self->error( $response->code );
        $self->errstr( $response->status_line );
        return undef;
    }
    
    if ( $response->content_type ne 'text/xml' ) {
        $self->error( '501' );
        $self->errstr(
            'Wrong Content-Type received: ' .
            $response->content_type
        );
        return undef;
    }
    
    return $response->content;
}

sub _get_xpc {
    my $self = shift;
    my $xml  = shift;
    
    my $doc = $self->parser->parse_string( $xml );
    my $xpc = XML::LibXML::XPathContext->new( $doc );
    $xpc->registerNs( 'p', 'http://services.sapo.pt/Metadata/PunyURL' );
    
    return $xpc;
}

sub _urlencode {
    my $self = shift;
    
    return uri_escape_utf8( $self->url, '^A-Za-z0-9_-' );
}

sub _build_browser {
    my $self = shift;
    
    my $ua = LWP::UserAgent->new;
    $ua->timeout( $self->timeout );
    $ua->env_proxy;
    
    return $ua;
}

sub _build_parser {
    return XML::LibXML->new;
}

1; # End of WWW::Shorten::PunyURL