The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl -w

# Script for making regression test patterns.
#
# Recommended use:
#
# $ perl -I../lib make-more-useragents.pl < /wherever/apache.log > more-useragents.json
#
# This will create a test suite based on any user agents that seem at
# all dissimilar to ones we're already testing. The answers are given
# by the same code that the test suite runs against, meaning the tests
# will start out all passing. The main usefulness is:
#
# (a) You can make -I different, getting the answers according to a
# different version of the code, and then run it against the current
# version to see what's different.
#
# (b) You can manually inspect the more-useragents.json file and see
# if there are any results in it that don't make sense.
#
# (c) Any changes in behavior in the future will cause a test failure.

use strict;

use FindBin;
use JSON::PP;
use Path::Tiny qw( path );

use HTTP::BrowserDetect;

my $json_text = path("$FindBin::Bin/useragents.json")->slurp;
my $tests     = JSON::PP->new->ascii->decode($json_text);

my %seen_tokens;

foreach my $ua ( sort keys %{$tests} ) {
    my @tokens = ( $ua =~ m{ (\w+) }g );
    foreach (@tokens) {
        $seen_tokens{$_} = 1;
    }
}

my %new_tests;

while (<>) {

    # Match tokens, either single words or quote- or bracket-delimited strings
    my @tokens = (
        $_ =~ m{ ( \"  [^\"]*      \"   |
                                  [^\[\]\"\s]+       |
                              \[  [^\[\]]*    \]   )
                    }xg
    );
    my ($ua) = ( $tokens[8] =~ m{\"(.*)\"} ) or next;
    @tokens = ( $ua =~ m{ (\w+) }g );    # Words within the user agent
    my $added = 0;
    foreach my $word (@tokens) {
        if ( !$seen_tokens{ lc $word } && !$added ) {
            my $test = {
                match => [],
            };

            my $detect = HTTP::BrowserDetect->new($ua);

            foreach my $method (
                qw(
                browser_string
                engine_string
                os_string
                os_version
                public_version
                public_major
                public_minor
                public_beta
                version
                major
                minor
                beta
                engine_version
                engine_major
                engine_minor
                language
                device
                device_name
                robot_name
                os_string )
                ) {
                my $result = $detect->$method;

                if ( defined($result) ) {
                    $test->{$method} = $result;
                }
            }

            for my $prop ( 'device', @HTTP::BrowserDetect::ALL_TESTS ) {
                if ( $detect->$prop ) {
                    push @{ $test->{match} }, $prop;
                }
            }

            $new_tests{$ua} = $test;
            $added = 1;
        }
        $seen_tokens{ lc $word } = 1;
    }
}

my $json   = JSON::PP->new->canonical->pretty;
my $output = $json->encode( \%new_tests );
print "$output\n";