# *********************************************************************
# This Source Code Form is copyright of 51Degrees Mobile Experts Limited.
# Copyright 2017 51Degrees Mobile Experts Limited, 5 Charlotte Close,
# Caversham, Reading, Berkshire, United Kingdom RG4 7BY
#
# This Source Code Form is the subject of the following patents and patent
# applications, owned by 51Degrees Mobile Experts Limited of 5 Charlotte
# Close, Caversham, Reading, Berkshire, United Kingdom RG4 7BY:
# European Patent No. 2871816;
# European Patent Application No. 17184134.9;
# United States Patent Nos. 9,332,086 and 9,350,823; and
# United States Patent Application No. 15/686,066.
#
# This Source Code Form is subject to the terms of the Mozilla Public
# License, v. 2.0.
#
# If a copy of the MPL was not distributed with this file, You can obtain
# one at http://mozilla.org/MPL/2.0/.
#
# This Source Code Form is "Incompatible With Secondary Licenses", as
# defined by the Mozilla Public License, v. 2.0.
# **********************************************************************
#!/usr/bin/env perl
{
# // Snippet Start
package TestServer;
use HTTP::Server::Simple::CGI;
use base qw(HTTP::Server::Simple::CGI);
use FiftyOneDegrees::PatternV3;
use String::Buffer;
# List of 51Degrees properties to make available. Where a property is not
# supported in the provided data file it will not be available.
my $propertyList = "BrowserName,BrowserVendor,BrowserVersion," .
"DeviceType,HardwareVendor,IsTablet,IsMobile," .
"IsCrawler,ScreenInchesDiagonal,ScreenPixelsWidth";
# Replace with the following lines for Premium or Enterprise data.
#
# my $filename = "../../data/51Degrees-PremiumV3.2.dat";
# my $filename = "../../data/51Degrees-EnterpriseV3.2.dat";
#
# Premium and Enterprise data files contain more properties, are updated
# more frequently and are more accurate than the free Lite data.
#
# See https://51degrees.com/compare-data-options to get data files.
#
# Set the location of the source data file for the web server.
my $filename = "../../data/51Degrees-LiteV3.2.dat";
# Create a device detection provider with a cache for 50,000 User-Agents
# and 20 concurrent detections.
my $provider = new FiftyOneDegrees::PatternV3::Provider(
$filename, $propertyList, 50000, 20);
# An array of the important HTTP headers in prefixed uppercase format
# (i.e. HTTP_USER_AGENT rather than User-Agent) to send to the detection
# algorithm.
my $importantHttpHeaders = $provider->getHttpHeaders();
# Array of all the properties available. May not match $propertyList as
# properties may not be supported by the provided data file.
my $properties = $provider->getAvailableProperties();
# The number of rows in a table listing each property requested.
my $propertyRows = (scalar (split(',', $propertyList)) + 1);
# Build some HTML button snippets to add to the generated page.
my $dataOptions;
if ('Lite' == $provider->getDataSetName()) {
$dataOptions = 'Compare Data Options';
}
my $methodHyperLinkUA = 'About Metrics';
my $propertiesHyperLinkUA = 'More Properties';
my $methodHyperLinkHeaders = 'About Metrics';
my $propertiesHyperLinkHeaders = 'More Properties';
my $propertyNotFound = 'Switch Data Set';
# Relate URL paths to response handlers.
my %dispatch = (
'/json' => \&resp_json,
);
# Listen for incoming requests performing device detection and providing
# simple output for the example.
sub handle_request {
my $self = shift;
my $cgi = shift; # CGI.pm object
return if !ref $cgi;
# Create a map with all relevant HTTP header names and values.
my %headers = map { $_ => $cgi->http($_) } $cgi->http();
my $matchingHttpHeaders = new FiftyOneDegrees::PatternV3::MapStringString();
foreach $httpHeader (@$importantHttpHeaders) {
my $value = $headers{$httpHeader};
if ($value) {
$matchingHttpHeaders->set($httpHeader, $value);
}
}
print "HTTP/1.0 200 OK\r\n";
my $handler = $dispatch{$cgi->path_info()};
if (ref($handler) ne "CODE") {
$handler = \&resp_default;
}
$handler->($cgi, $matchingHttpHeaders);
}
# Provides a JSON plan text response with properties for the requesting device.
sub resp_json {
my $cgi = shift;
my $matchingHttpHeaders = shift;
print $cgi->header('text/plain');
# Get the JSON for the available properties for these headers.
my $json = $provider->getMatchJson($matchingHttpHeaders);
# Display the result.
print $json;
}
# Outputs a standard HTML table with the match results.
sub resp_match {
my $match = shift;
foreach $property (split(',', $propertyList)) {
my $values = $match->getValues($property);
print '
';
if ($matchingHttpHeaders->has_key($headerName)) {
print $matchingHttpHeaders->get($headerName);
} else {
print 'header not set';
}
print '
';
}
print '
';
my $match = $provider->getMatch($matchingHttpHeaders);
print '
';
print '
Match Metrics
' . $methodHyperLinkHeaders . '
';
print '
Id
' . $match->getDeviceId() . '
';
print '
Method
' . $match->getMethod() . '
';
print '
Difference
' . $match->getDifference() . '
';
print '
Rank
' . $match->getRank() . '
';
print '
Device Properties
' . $propertiesHyperLinkHeaders . '
';
resp_match($match);
print '';
print '';
print '';
}
}
# start the server on port 8080
my $pid = TestServer->new(8080)->background();
print "Use 'kill $pid' to stop server.\n";
# // Snippet End