#!/usr/bin/perl -w -I.
##
## Copyright (c) 2002 Rainer Hillebrand, rainer.hillebrand@webcab.de.
## All rights reserved.
##
## This program is free software; you can redistribute it
## and/or modify it under the same terms as Perl itself.
##
## The latest version can be found at:
##   http://webcab.de/WURFL/
##
## Version 0.02, 2003-02-07
##
## This Perl script prints out all capabilities for a browser with a given
## user-agent HTTP header field. The capabilities are recursively derived from
## all fall back browsers starting with the device_id "generic".

use WURFLLite;
use vars qw($dbm $file_date $file_exists $ua %ua_found $WURFL $WURFLdb);
eval {
BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File SDBM_File) }; # look at www.cpan.org for the latest versions
use AnyDBM_File;
#  use MLDBM qw(AnyDBM_File); # look at www.cpan.org for the latest version
use MLDBM qw(AnyDBM_File Storable); # Storable is much faster than Data::Dumper
# It takes about 70 seconds on my 1 GHz to store the WURFL XML file in a DB_File
# database using Data::Dumper.
use Fcntl qw(:DEFAULT :flock);
};
if ($@){
$dbm = 0;
}
else {
$dbm = 1;
}

$ua = 'Sanyo-SCP4700/1.1 UP.Browser/4.1.24f UP.Link/5.0.2.3c'; # user-agent to search for
$WURFL = './wurfl.xml'; # location of the WURFL XML file
$WURFLdb = './my-wurfl.db'; # location of the local WURFL database

if (-f $WURFL) {
$file_exists = 1;
$file_date = (stat($WURFL))[9];
}
else {
$file_exists = 0;
}

my %wurfl_parsed;

if ($dbm) {
my (%WURFLdb);
unless (tie(%WURFLdb, 'MLDBM', $WURFLdb, O_RDWR|O_CREAT, 0666)){
print("Cannot open or create the local WURFL database!\n");
}
if ($file_exists and (not exists $WURFLdb{'file_date'} or $WURFLdb{'file_date'} != $file_date)) {
#print "The database has another date than the file. The database will be updated.\n";
open(IN, "<$WURFL") || die("Can't open WURFL XML file $WURFL: $!.");
my $content;
while (<IN>) {
$content .= $_;
}
parseXML(\%wurfl_parsed, \$content);
my $time = time();
%WURFLdb = %wurfl_parsed;
print "It took ", time() - $time, " seconds to store the hash in the database.\n";
$WURFLdb{'file_date'} = $file_date;
}
else {
#print "The database has the same date as the file or the file does not exist.\n";
%wurfl_parsed = %WURFLdb;
}
untie %WURFLdb;
}
elsif ($file_exists) {
#print "No database module can be used and the file exists.\n";
open(IN, "<$WURFL") || die("Can't open WURFL XML file $WURFL: $!.");
my $content;
while (<IN>) {
$content .= $_;
}
parseXML(\%wurfl_parsed, \$content);
}
else {
print "Neither a local WURFL XML file exists nor a local WURFL database can be created.\n";
exit;
}

%ua_found = (device_id => 'generic',
ua_length => 0);

while (my($device_id, undef) = each(%{$wurfl_parsed{'devices'}})) {
if (defined $wurfl_parsed{'devices'}->{$device_id}->{'attributes'}->{'user_agent'} and
$wurfl_parsed{'devices'}->{$device_id}->{'attributes'}->{'user_agent'} ne '' and
$ua =~ m|^\Q$wurfl_parsed{'devices'}->{$device_id}->{'attributes'}->{'user_agent'}\E| and
length($wurfl_parsed{'devices'}->{$device_id}->{'attributes'}->{'user_agent'}) > $ua_found{'ua_length'}) {
$ua_found{'device_id'} = $device_id;
$ua_found{'ua_length'} = length($wurfl_parsed{'devices'}->{$device_id}->{'attributes'}->{'user_agent'});
}
}
$device_id = $ua_found{'device_id'};

if (defined %{$wurfl_parsed{'devices'}->{$device_id}}) {
print "Device ID: $device_id\n\n",
"  Attributes:\n";
foreach my $attribute (sort {lc($a) cmp lc($b)} keys (%{$wurfl_parsed{'devices'}->{$device_id}->{'attributes'}})) {
print
"    $attribute: ", $wurfl_parsed{'devices'}->{$device_id}->{'attributes'}->{$attribute}, "\n";

}
print "\n  Capabilities:\n";
my $has_fall_backs = 1;
my @device_ids = ($device_id);
my $fallback = $device_id;
while ($has_fall_backs) {
if (defined $wurfl_parsed{'devices'}->{$fallback}->{'attributes'}->{'fall_back'} and
$wurfl_parsed{'devices'}->{$fallback}->{'attributes'}->{'fall_back'} ne '' and
$wurfl_parsed{'devices'}->{$fallback}->{'attributes'}->{'fall_back'} ne 'root') {
push(@device_ids, $wurfl_parsed{'devices'}->{$fallback}->{'attributes'}->{'fall_back'});
$fallback = $wurfl_parsed{'devices'}->{$fallback}->{'attributes'}->{'fall_back'};
}
else {
$has_fall_backs = 0
}
}
my (%capabilities, $device);
while ($device = pop(@device_ids)) {
foreach my $group (sort {lc($a) cmp lc($b)} keys (%{$wurfl_parsed{'devices'}->{$device}->{'capabilities'}})) {
foreach my $capability (sort {lc($a) cmp lc($b)} keys (%{$wurfl_parsed{'devices'}->{$device}->{'capabilities'}->{$group}})) {
$capabilities{$group}->{$capability} = $wurfl_parsed{'devices'}->{$device}->{'capabilities'}->{$group}->{$capability};
}
}
}
foreach my $group (sort {lc($a) cmp lc($b)} keys (%capabilities)) {
print
"    $group:\n";
foreach my $capability (sort {lc($a) cmp lc($b)} keys (%{$capabilities{$group}})) {
print
"      $capability: ", $capabilities{$group}->{$capability}, "\n";
}
}
}
else {
print "The device with the ID $device_id does not exist!";
}