docomo.pl

#!/usr/bin/perl

use utf8;
use strict;
use warnings;

use Carp;
use HTML::TreeBuilder::LibXML;
use LWP::UserAgent;
use Perl6::Say;
use YAML;

my $uri = 'http://www.nttdocomo.co.jp/service/imode/make/content/spec/useragent/';
my $ua  = LWP::UserAgent->new;

my $res = $ua->get($uri);
croak($res->status_line) unless ($res->is_success);

my $tree = HTML::TreeBuilder::LibXML->new;
$tree->parse($res->content);

my @table_nodes = $tree->findnodes(q|//div[@class="section"]/table|);
my @results;

for my $table_node (@table_nodes) {
    my $models = extract_table($table_node);
    push(@results, $models);
}

say Dump \@results;

sub extract_table {
    my $table_node = shift;
    my $summary = $table_node->findvalue('./@summary');

    my @models = ();
    my $version = '';

    if ($summary =~ /HTML([13]\.0)/) {
        $version = 'HTML ' . $1;
        my $series = '';
        my @model_nodes = $table_node->findnodes(q|./tr[not(contains(./td/@class, "brownLight"))]|);
        for my $model_node (@model_nodes) {
            $series = $model_node->findvalue(q|./td[contains(@class, "acenter")]/span|) || $series;

            my $ua_val = $model_node->findvalue(q|./td[not(contains(@class, "acenter"))][2]/span|);
            my @user_agents = ( $ua_val =~ m#(?:DoCoMo/2\.0 \w+\([\w;]+\)|DoCoMo/1\.0/\w+(?:/\w+)*)#g );
            
            push(@models, +{
                name => normalize_name($model_node->findvalue(q|./td[not(contains(@class, "acenter"))][1]/span|)),
                user_agent => \@user_agents,
                series => $series,
            });
        }
    }
    elsif ($summary =~ /HTML(2\.0)/) {
        $version = 'HTML ' . $1;
        my $series = '';
        my @model_nodes = $table_node->findnodes(q|./tr[not(contains(./td/@class, "brownLight"))]|);
        for my $model_node (@model_nodes) {
            $series = $model_node->findvalue(q|./td[contains(@class, "acenter")]/span|) || $series;
            push(@models, +{
                name => normalize_name($model_node->findvalue(q|./td[not(contains(@class, "acenter"))][1]/span|)),
                user_agent => [ grep { $_ } (
                    $model_node->findvalue(q|./td[not(contains(@class, "acenter"))][2]/span|),
                    $model_node->findvalue(q|./td[not(contains(@class, "acenter"))][3]/span|),
                )],
                series => $series,
            });
        }
    }
    elsif ($summary =~ /HTML([4-7]\.0|7\.1|7\.2)/) {
        $version = 'HTML ' . $1;
        my $series = '';
        my @model_nodes = $table_node->findnodes(q|./tr[not(contains(./td/@class, "brownLight"))]|);
        for my $model_node (@model_nodes) {
            $series = $model_node->findvalue(q|./td[contains(@class, "acenter")]/span|) || $series;

            my $ua_val = $model_node->findvalue(q|./td[not(contains(@class, "acenter"))][2]/span|);
            my @user_agents = ( $ua_val =~ m#(?:DoCoMo/2\.0 \w+\([\w;]+\)|DoCoMo/1\.0/\w+(?:/\w+)*)#g );
            
            push(@models, +{
                name => normalize_name($model_node->findvalue(q|./td[not(contains(@class, "acenter"))][1]/span|)),
                user_agent => \@user_agents,
                series => $series,
            });
        }
    }
    else {
        $version = 'i-mode browser 2.0';
        my $series = '';
        my @model_nodes = $table_node->findnodes(q|./tr[not(contains(./td/@class, "brownLight"))]|);
        for my $model_node (@model_nodes) {
            my $ua_val = $model_node->findvalue(q|./td[not(contains(@class, "acenter"))][2]/span|);
            my @user_agents = ( $ua_val =~ m#(?:DoCoMo/2\.0 \w+\([\w;]+\)|DoCoMo/1\.0/\w+(?:/\w+)*)#g );
            
            push(@models, +{
                name => normalize_name($model_node->findvalue(q|./td[not(contains(@class, "acenter"))][1]/span|)),
                user_agent => \@user_agents,
                series => 'i-mode 2.0',
            });
        }
    }
    
    return +{
        version => $version,
        models  => \@models
    };
}

sub normalize_name {
    my $name = shift;
    $name =~ s|（[\w\W]+）||; # 
    $name;
}

ezweb.pl

#!/usr/bin/perl

use strict;
use warnings;

use Carp;
use LWP::UserAgent;
use Perl6::Say;
use Text::CSV_XS;
use WWW::MobileCarrierJP::EZWeb::DeviceID;
use YAML;

my $ua = LWP::UserAgent->new;
my $res = $ua->get('http://ke-tai.org/moblist/csv_down.php');
croak($res->status_line) unless ($res->is_success);

my %name_to_ua = ();
my $csv = Text::CSV_XS->new(+{
    binary => 1,
});

my @lines = split /\r\n/ => $res->content;
shift @lines;

for my $line (@lines) {
    $csv->parse($line);
    my @fields = $csv->fields;
    next unless ($fields[1] eq 'au');
    $name_to_ua{$fields[3]} = $fields[4];
}

my $devices = WWW::MobileCarrierJP::EZWeb::DeviceID->scrape;
my @results;

for my $device (@$devices) {
    push(@results, +{
        name => $device->{device_id},
        model_name => $device->{model},
        user_agent => $name_to_ua{$device->{device_id}}, # sprintf('KDDI-%s UP.Browser/6.2.0.7.3.129 (GUI) MMP/2.0'),
    }) if (exists $name_to_ua{$device->{device_id}});
}

say Dump \@results;

thirdforce.pl

#!/usr/bin/perl

use utf8;
use strict;
use warnings;

use Perl6::Say;
use WWW::MobileCarrierJP::ThirdForce::HTTPHeader;
use WWW::MobileCarrierJP::ThirdForce::UserAgent;
use YAML;

my $headers = WWW::MobileCarrierJP::ThirdForce::HTTPHeader->scrape;
my $uas = WWW::MobileCarrierJP::ThirdForce::UserAgent->scrape;
my $ret = +{};
my %model_to_name = ();

for my $header (@$headers) {
    my $name = $header->{'x-jphone-name'};
    my $model_name = $header->{model};
    $ret->{$name} = +{
        model_name => $model_name,
        headers => +{},
        user_agent => '',
        has_serial => 0,
    };

    for my $header_name (grep { $_ ne 'model' } keys %$header) {
        $header->{$header_name} =~ s/\r//g if ($header->{$header_name});
        $ret->{$name}->{headers}->{$header_name} = $header->{$header_name} if ($header->{$header_name});
    }

    $model_to_name{$model_name} = $ret->{$name};
}

for my $ua (@$uas) {
    my $model_name = $ua->{model};
    my $user_agent = $ua->{user_agent};
    $user_agent =~ s/[\r\n]//g;
    $user_agent =~ s|(\[/Serial\])||g;
    if ($1) {
        $model_to_name{$model_name}->{has_serial} = 1;
    }
    $model_to_name{$model_name}->{user_agent} = $user_agent;
}

say Dump $ret;