The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use warnings;

package WWW::XBoxLive;
{
  $WWW::XBoxLive::VERSION = '1.123160';
}

# ABSTRACT: Get XBox Live Gamercard information

use WWW::XBoxLive::Gamercard;
use WWW::XBoxLive::Game;

use LWP::Simple              ();
use HTML::TreeBuilder::XPath ();

# the gamercard url
use constant GAMERCARD_URL => 'http://gamercard.xbox.com/%s/%s.card';

# if a user has this avatar, they are not a user
use constant INVALID_AVATAR =>
  'http://image.xboxlive.com//global/t.FFFE07D1/tile/0/20000';


sub new {
    my $class = shift;
    my $args  = shift || {};
    my $self  = {};

    bless( $self, $class );

    $self->{region} = $args->{region} || 'en-US';

    return $self;
}


sub get_gamercard {
    my ( $this, $gamertag ) = @_;

    # get the html
    my $html =
      LWP::Simple::get( sprintf( GAMERCARD_URL, $this->{region}, $gamertag ) );

    # parse
    my $gamercard = $this->_parse_gamercard($html);

    return $gamercard;
}

# parse the HTML
sub _parse_gamercard {
    my ( $this, $html ) = @_;

    # generate HTML tree
    my $tree = HTML::TreeBuilder::XPath->new_from_content($html);

    # get the gamertag
    my $gamertag = _trimWhitespace( $tree->findvalue('//title') );

    # is valid? If not, then skip everything else
    my $gamerpic = $tree->findvalue('//img[@id="Gamerpic"]/@src');
    if ( $gamerpic eq INVALID_AVATAR ) {
        return WWW::XBoxLive::Gamercard->new(
            gamertag => $gamertag,
            is_valid => 0,
        );
    }

    my $bio = _trimWhitespace( $tree->findvalue('//div[@id="Bio"]') );
    my $gamerscore =
      _trimWhitespace( $tree->findvalue('//div[@id="Gamerscore"]') );
    my $motto    = _trimWhitespace( $tree->findvalue('//div[@id="Motto"]') );
    my $location = _trimWhitespace( $tree->findvalue('//div[@id="Location"]') );
    my $name     = _trimWhitespace( $tree->findvalue('//div[@id="Name"]') );
    my $profile_link = $tree->findvalue('//a[@id="Gamertag"]/@href');

    # guess account status
    my $account_status = 'unknown';
    if ( $tree->exists('//body/div[@class=~ /Gold/]') ) {
        $account_status = 'gold';
    }
    elsif ( $tree->exists('//body/div[@class=~ /Silver/]') ) {
        $account_status = 'silver';
    }

    # find gender
    my $gender = 'unknown';
    if ( $tree->exists('//body/div[@class=~ /Male/]') ) {
        $gender = 'male';
    }
    elsif ( $tree->exists('//body/div[@class=~ /Female/]') ) {
        $gender = 'female';
    }

    # count the reputation stars
    my @reputation_stars =
      $tree->findnodes('//div[@class="RepContainer"]/div[@class="Star Full"]');
    my $reputation = scalar @reputation_stars;

    # games
    my @recent_games;
    my $i = 1;
    while (
        my $title = $tree->findvalue(
            '//ol[@id="PlayedGames"]/li[' . $i . ']/a/span[@class="Title"]'
        )
      )
    {
        my $last_played =
          $tree->findvalue( '//ol[@id="PlayedGames"]/li[' 
              . $i
              . ']/a/span[@class="LastPlayed"]' );
        my $earned_gamerscore =
          $tree->findvalue( '//ol[@id="PlayedGames"]/li[' 
              . $i
              . ']/a/span[@class="EarnedGamerscore"]' );
        my $available_gamerscore =
          $tree->findvalue( '//ol[@id="PlayedGames"]/li[' 
              . $i
              . ']/a/span[@class="AvailableGamerscore"]' );
        my $earned_achievements =
          $tree->findvalue( '//ol[@id="PlayedGames"]/li[' 
              . $i
              . ']/a/span[@class="EarnedAchievements"]' );
        my $available_achievements =
          $tree->findvalue( '//ol[@id="PlayedGames"]/li[' 
              . $i
              . ']/a/span[@class="AvailableAchievements"]' );
        my $percentage_complete =
          $tree->findvalue( '//ol[@id="PlayedGames"]/li[' 
              . $i
              . ']/a/span[@class="PercentageComplete"]' );

        my $game = WWW::XBoxLive::Game->new(
            available_achievements => $available_achievements,
            available_gamerscore   => $available_gamerscore,
            earned_achievements    => $earned_achievements,
            earned_gamerscore      => $earned_gamerscore,
            last_played            => $last_played,
            percentage_complete    => $percentage_complete,
            title                  => $title,
        );

        push @recent_games, $game;
        $i++;
    }

    # to ensure we do not have memory leaks
    $tree->delete;

    # create new gamercard
    my $gamercard = WWW::XBoxLive::Gamercard->new(
        account_status => $account_status,
        bio            => $bio,
        gamerscore     => $gamerscore,
        gamertag       => $gamertag,
        gender         => $gender,
        is_valid       => 1,
        location       => $location,
        motto          => $motto,
        name           => $name,
        profile_link   => $profile_link,
        recent_games   => \@recent_games,
        reputation     => $reputation,
    );

    return $gamercard;
}

# trims whitespace from a string
sub _trimWhitespace {
    my $string = shift;
    $string =~ s/^\s+//;
    $string =~ s/\s+$//;
    return $string;
}

1;


__END__
=pod

=head1 NAME

WWW::XBoxLive - Get XBox Live Gamercard information

=head1 VERSION

version 1.123160

=head1 SYNOPSIS

  my $xbox_live = WWW::XBoxLive->new();

  my $gamercard = $xbox_live->get('BrazenStraw3');

  say $gamercard->name;
  say $gamercard->bio;

  for my $game (@{ $gamercard->recent_games }){
    say $game->title;
    say $game->last_played;
  }

=head1 DESCRIPTION

This is a module to get and parse an XBox Live Gamercard (i.e. L<http://gamercard.xbox.com/en-US/BrazenStraw3.card>).

=head1 METHODS

=head2 new(region => 'en-US')

Create a new WWW::XBoxLive object. Optionally takes a region argument, which defaults to 'en-US'.

=head2 get_gamercard( $gamertag )

Get a gamercard. Returns an L<WWW::XBoxLive::Gamercard> object.

=head1 SEE ALSO

=over 4

=item *

L<WWW::XBoxLive::Gamercard>

=item *

L<WWW::XBoxLive::Game>

=back

=head1 CREDITS

Jason Clemons wrote a PHP version, which helped me write this version. It is available at L<https://github.com/JBlaze/Xbox-Gamercard-Data>.

=head1 AUTHOR

Andrew Jones <andrew@arjones.co.uk>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011 by Andrew Jones.

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

=cut