File Coverage

blib/lib/WWW/ColiPoste.pm

Criterion	Covered	Total	%
statement	65	75	86.6
branch	5	16	31.2
condition	2	7	28.5
subroutine	10	10	100.0
pod	2	2	100.0
total	84	110	76.3

package WWW::ColiPoste;
use strict;
use warnings;
use Carp;
use File::Slurp;
use HTML::Entities;
use HTML::TreeBuilder;
use LWP::UserAgent;


{
    no strict "vars";
    $VERSION = '0.03';
}


=head1 NAME

WWW::ColiPoste - Fetch shipping status from ColiPoste

=head1 VERSION

Version 0.03

=head1 SYNOPSIS

    use WWW::ColiPoste;

    my $coliposte = WWW::ColiPoste->new;
    my $status = $coliposte->get_status(tracking_id => $id);


=head1 DESCRIPTION

This module allows you to fetch the status of packages shipped by
ColiPoste, the service from the French national postal service.

Please note that this module works by web-scrapping, and doesn't
do any transformation or parsing on the data apart from basic cleanup.
Especially, the dates and messages are as given by the web site,
in French.

B Thanks to La Poste corporate thinking, this module is
no longer useful (since 2009), because they replaced the texts in the
result page with images (just in case their service was still usable).


=head1 METHODS

=head2 new()

Create a new objet.

=cut

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

    my $self = bless {}, $class;
    $self->{agent} = LWP::UserAgent->new;

    return $self
}

=head2 get_status()

Fetch the tracking status of the given shipment ID. Returns the
corresponding tracking data as an array reference with the following
sub-structure:

    [
        {
            date    => STRING,
            site    => STRING,
            status  => STRING,
        },
        ...
    ]

B

=over

=item *

C - I<(mandatory)> tracking ID of the package

=item *

C - I<(optional)> source URI or file

=item *

C - I<(optional)> use this LWP agent or code reference for
fetching from the remote site

=back

B

    my $status = $coliposte->get_status(tracking_id => $id);

=cut

sub get_status {
    my ($self, %args) = @_;
    my $content;

    exists $args{tracking_id} or croak "error: required parameter: tracking_id";
    my $agent = $args{using};

    if (ref $args{from}) {
        my $src  = $args{from};
        my $type = ref $src;

        if    ($type eq "SCALAR") { $content = $$src }
        elsif ($type eq "ARRAY" ) { $content = join "", @$src }
        else { croak "error: don't know how to handle a \L$type reference" }
    }
    else {
        # construct the URL
        my $base_uri = $args{from}
            || "http://www.coliposte.net/particulier/suivi_particulier.jsp?colispart=%s";
        (my $url = $base_uri) =~ s/%s/$args{tracking_id}/;

        # fetch the content
        if (-f $url) {
            $content = read_file($url);
            $content =~ /Content-Type[^>]+charset=([^">]+)"[^>]*>/;
            my $encoding = $1 || "iso-8859-1";
            require Encode;
            $content = Encode::decode($encoding, $content);
        }
        elsif (ref $agent eq "CODE") {
            $content = $agent->($url)
        }
        elsif (ref $agent and eval { $agent->isa("LWP::UserAgent") }) {
            $content = $agent->get($url)->decoded_content;
        }
        else {
            $content = $self->{agent}->get($url)->decoded_content;
        }
    }

    my $tree = HTML::TreeBuilder->new_from_content($content);
    my $nbsp = decode_entities(" ");
    my @table;

    for my $table_node ($tree->look_down(_tag => "table", width => "100%")) {
        for my $tr_node ($table_node->look_down(_tag => "tr")) {
            my @row =
                grep { !/^\s*$/ }
                map { s/\( +/(/g; s/ +\)/)/g; $_ }
                map { s/[$nbsp[:blank:][:cntrl:]]+/ /g; s/^\s*|\s*$//g; $_ }
                map { $_->as_trimmed_text }
                $tr_node->look_down(_tag => qr/^t[dh]$/);
            push @table, \@row if @row;
        }
    }

    # remove the parts that don't interest us
    my $filter = join "|", "Entrez ici votre", "FAQ", "Guide du site";
    @table = grep { not $_->[0] =~ /$filter/ } @table;

    my @fields = qw(date status site);
    my @status = ();

    for my $line (reverse @table[2..$#table]) {
        push @status, { map { $fields[$_] => $line->[$_] } 0..$#fields }
    }

    return \@status
}


=head1 AUTHOR

SEbastien Aperghis-Tramoni, C<<  >>

=head1 BUGS

Please report any bugs or feature requests
to C, or through the web interface
at L.
I will be notified, and then you'll automatically be notified of
progress on your bug as I make changes.


=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc WWW::ColiPoste

You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back


=head1 COPYRIGHT & LICENSE

Copyright 2008 SEbastien Aperghis-Tramoni, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1   # End of WWW::ColiPoste